packages feed

com (empty) → 1.1

raw patch · 39 files changed

+15618/−0 lines, 39 filesdep +basedep +haskell98dep +old-timesetup-changed

Dependencies added: base, haskell98, old-time

Files

+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) Sigbjorn Finne, 2008.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,9 @@+#!/usr/bin/runhugs
+
+> module Main where
+
+> import Distribution.Simple
+
+> main :: IO ()
+> main = defaultMain
+
+ System/Win32/Com.hs view
@@ -0,0 +1,965 @@+{-# OPTIONS -#include "comPrim.h" -#include "PointerSrc.h" #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Win32.Com
+-- Copyright   :  (c) Sigbjorn Finne, sof@dcs.gla.ac.uk 1999
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+-- 
+-- Maintainer  :  sof@galois.com
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- Support library for using and generating client stubs
+-- for Com objects.
+-- 
+-----------------------------------------------------------------------------
+module System.Win32.Com
+    (
+      -- base COM interface, IUnknown:
+      IUnknown_ 	-- abstract, instance of: Eq, Show.
+    , IUnknown		
+    , iidIUnknown	-- :: IID (IUnknown ())
+    
+    , interfaceNULL, isNullInterface, iidNULL
+
+      -- its methods:
+    , queryInterface	 -- :: IID (IUnknown b) -> IUnknown a -> IO (IUnknown b)
+    , addRef		 -- :: IUnknown a -> IO Word32
+    , release		 -- :: IUnknown a -> IO Word32
+    , withQueryInterface -- :: IID (IUnknown b) -> IUnknown a -> (IUnknown b -> IO c) -> IO c
+
+      -- helpful operators:
+    , ( # )		-- :: a -> (a -> IO b) -> IO b
+    , ( ## )		-- :: IO a -> (a -> IO b) -> IO b
+
+
+      -- setting up and shutting down.
+    , coRun		  -- :: IO a -> IO a
+    , coPerformIO         -- :: IO a -> IO a
+    , coUnsafePerformIO   -- :: IO a -> a
+    , coInitialize	  -- :: IO ()
+    , coUnInitialize	  -- :: IO ()
+    
+      -- GUID API:
+    , GUID		-- abstract, instance of: Eq, Show
+    , mkGUID		-- :: String -> GUID
+    , newGUID           -- :: IO GUID
+    , stringToGUID	-- :: String -> IO GUID
+    , guidToString	-- :: GUID   -> String
+    , nullGUID		-- :: GUID
+
+      -- IID API:
+    , IID		-- abstract, instance of: Eq, Show
+    , mkIID		-- :: String -> IID a
+    , stringToIID	-- :: String -> IO (IID a)
+    , guidToIID		-- :: GUID   -> IID a
+    , iidToGUID		-- :: IID a  -> GUID
+    , castIID           -- :: IID a  -> IID b
+
+      -- CLSID API:
+    , CLSID		 -- abstract, instance of: Eq, Show
+    , mkCLSID		 -- :: String -> CLSID
+    , stringToCLSID	 -- :: String -> IO CLSID
+    , guidToCLSID	 -- :: GUID   -> CLSID
+    , clsidToGUID	 -- :: CLSID  -> GUID
+    , clsidToDisplayName -- :: CLSID  -> String
+
+      -- LIBID
+    , LIBID		-- (a guid)
+    , mkLIBID           -- :: String -> LIBID
+
+      -- HRESULT API:
+    , HRESULT
+    , s_FALSE		-- :: HRESULT
+    , s_OK		-- :: HRESULT
+    , succeeded	        -- :: HRESULT -> Bool
+    , failed	        -- :: HRESULT -> Bool
+    , checkHR		-- :: HRESULT -> IO ()
+    , checkBool		-- :: Int32   -> IO ()
+    , returnHR		-- :: IO ()   -> IO HRESULT
+    , coFailHR		-- :: HRESULT -> IO a
+    , coFailWithHR	-- :: HRESULT -> String  -> IO 
+    , coAssert		-- :: Bool    -> String -> IO ()
+    , coOnFail		-- :: IO a    -> String -> IO a
+    , coFail		-- :: String  -> IO a
+    , isCoError		-- :: IOError -> Bool
+    , coGetErrorHR      -- :: IOError -> HRESULT
+    , coGetErrorString  -- :: IOError -> String
+    , hresultToString   -- :: HRESULT -> IO String
+
+      -- component creation:
+    , coCreateInstance -- :: CLSID -> Maybe (IUnknown b) -> CLSCTX
+		       -- -> IID (IUnknown a) -> IO (IUnknown a)
+    , coCreateObject
+    , coGetObject
+    , coGetActiveObject
+    , coGetFileObject
+    , coCreateInstanceEx
+    , COSERVERINFO(..)
+    , COAUTHIDENTITY(..)
+    , COAUTHINFO(..)
+
+    , withObject   -- :: IUnknown a -> [IUnknown a -> IO b] -> IO [b]
+    , withObject_  -- :: IUnknown a -> [IUnknown a -> IO b] -> IO ()
+    , withMethod   -- :: (a -> IUnknown b -> IO c) -> [a] -> IUnknown b -> IO [c]
+    , withMethod_  -- :: (a -> IUnknown b -> IO c) -> [a] -> IUnknown b -> IO ()
+
+
+    , CLSCTX(..)
+
+    , ProgID
+    , progIDFromCLSID     -- :: CLSID  -> IO ProgID
+    , clsidFromProgID     -- :: ProgID -> IO CLSID
+
+    , printMessage
+    , putMessage
+    , messageBox
+    , outputDebugString
+
+    , OSVersionInfo(..)
+    , isWindowsNT          -- :: OSVersionInfo -> Bool
+    , isWindows95          -- :: OSVersionInfo -> Bool
+    , isWindows98          -- :: OSVersionInfo -> Bool
+    , versionInfo	   -- :: OSVersionInfo
+
+    , ifaceToAddr
+    
+      -- IEnum* methods.
+    , enumNext
+    , enumClone
+    , enumReset
+    , enumSkip
+    
+    , BSTR
+    , marshallBSTR
+    , unmarshallBSTR
+    , readBSTR
+    , writeBSTR
+    , freeBSTR
+    , LPSTR
+    
+    , coFree
+    , coAlloc
+    
+    , marshallIUnknown
+    , unmarshallIUnknown
+    , readIUnknown
+    , writeIUnknown
+    
+    , unmarshallIUnknownFO
+    , castIface
+    
+      -- Re-export WideStrings
+    , WideString
+    , marshallWideString
+    , unmarshallWideString
+    , writeWideString
+    , readWideString
+    , sizeofWideString
+    , freeWideString
+    
+      -- marshallers
+    , marshallGUID	-- :: GUID -> IO (ForeignPtr GUID)
+    , unmarshallGUID	-- :: Bool -> Ptr GUID -> IO GUID
+    , writeGUID
+    , readGUID
+    , copyGUID
+    , sizeofGUID
+    
+      -- marshallers
+    , marshallIID	-- :: GUID -> IO (ForeignPtr GUID)
+    , unmarshallIID	-- :: Bool -> Ptr GUID -> IO GUID
+    , writeIID
+    , readIID
+    , sizeofIID
+    , copyIID
+    
+      -- marshallers
+    , marshallCLSID	-- :: CLSID -> IO (ForeignPtr CLSID)
+    , unmarshallCLSID	-- :: Bool -> Ptr CLSID -> IO GUID
+    , writeCLSID
+    , readCLSID
+    , sizeofCLSID
+    , copyCLSID
+    
+    , invokeAndCheck
+    , invokeIt
+    
+    , loadTypeLib
+    , loadTypeLibEx
+    , loadRegTypeLib
+    , queryPathOfRegTypeLib
+    , createTypeLib
+    
+    , LCID
+    
+    , messagePump
+    , postQuitMsg
+    
+    ) where
+
+
+import System.Win32.Com.Exception
+import System.Win32.Com.Base 
+	       hiding ( coCreateInstance, loadTypeLib, messageBox,
+			loadTypeLibEx, loadRegTypeLib, coCreateInstanceEx
+		      )
+import qualified System.Win32.Com.Base as Base
+		      ( coCreateInstance, loadTypeLib, messageBox,
+			   loadTypeLibEx, loadRegTypeLib, coCreateInstanceEx
+		      )
+import System.Win32.Com.HDirect.HDirect
+import System.Win32.Com.HDirect.Pointer hiding ( freeBSTR )
+import qualified System.Win32.Com.HDirect.Pointer as P ( freeBSTR )
+import System.Win32.Com.HDirect.WideString
+import System.IO.Unsafe  ( unsafePerformIO )
+import Control.Monad     ( when )
+import Foreign.StablePtr ( deRefStablePtr )
+import Foreign.Ptr
+import Foreign.ForeignPtr
+import Foreign.Storable
+import Data.Bits
+import IO         ( bracket ) 
+
+infixl 1 #
+infixl 0 ##
+
+--Operators to provide OO-looking invocation of interface methods, e.g., 
+--
+--   ip # meth1 args
+
+( # )  :: a -> (a -> IO b) -> IO b
+obj # method          = method obj
+
+( ## ) :: IO a -> (a -> IO b) -> IO b
+mObj ## method        = mObj >>= method
+
+
+--IPersistFile - doesn't really belong here..
+
+data PersistFile a    = PersistFile
+type IPersistFile a   = IUnknown (PersistFile a)
+
+iidIPersistFile       :: IID (IPersistFile ())
+iidIPersistFile       = mkIID "{0000010B-0000-0000-C000-000000000046}"
+
+{-
+Create instance.
+
+@coCreateInstance@ is the basic COM way of creating components. It takes
+a CLSID, an interface to aggregate on, a process context and an IID to create an object:
+@coCreateInstance clsidAgentServer interfaceNULL LocalProcess iidIAgent@.
+-}
+coCreateInstance :: CLSID 
+		 -> Maybe (IUnknown b)  
+		 -> CLSCTX 
+		 -> IID (IUnknown a) 
+		 -> IO (IUnknown a)
+coCreateInstance clsid inner context iid = do
+  ppvObject <- allocOutPtr
+  clsid     <- marshallCLSID clsid
+  inner     <- marshallInner inner
+  let ctxt   = fromEnum context
+  iid       <- marshallIID iid
+  Base.coCreateInstance (castForeignPtr clsid) inner (fromIntegral ctxt)
+  			   (castForeignPtr iid) ppvObject
+  doThenFree free (readIUnknown False{-finalise only-}) ppvObject
+
+coCreateInstanceEx :: CLSID 
+		   -> Maybe (IUnknown b)  
+		   -> CLSCTX 
+		   -> Maybe COSERVERINFO
+		   -> IID (IUnknown a) 
+		   -> IO (IUnknown a)
+coCreateInstanceEx clsid pUnkOuter context mbServ iid = do
+  clsid     <- marshallCLSID clsid
+  pUnkOuter <- marshallInner pUnkOuter
+  let ctxt   = fromEnum context
+  iid       <- copyGUID (iidToGUID iid)
+  let mqi = [ MULTI_QI iid nullPtr 0 ]
+  r <- Base.coCreateInstanceEx (castForeignPtr clsid) pUnkOuter (fromIntegral ctxt) mbServ mqi
+  case r of
+    (MULTI_QI iid pItf hr:_) -> do
+      coFree iid
+      checkHR hr
+      unmarshallIUnknown True{-finalise it-} pItf
+    _ -> coFailHR e_FAIL
+
+marshallInner :: Maybe (IUnknown a) -> IO (ForeignPtr b)
+marshallInner Nothing  = return nullFO
+marshallInner (Just v) = marshallIUnknown v
+
+{-
+Create Objects: 
+  prepend @co@ to specify the initial IID, otherwise @iidIDispatch@ is
+  used (see @Automation@ library for more).
+
+@createObject@ creates an object from its progID: @createObject "Agent.Server"@.
+@getObject@ creates an object from its progID and initializes it with a given file:
+@getObject "spreadsheet.exl" "Excel.Application"@. If the filename is empty,
+@getObject@ calls @getActiveObject@.
+@getActiveObject@ tries to connect to an already running instance of the component:
+@getActiveObject "Word.Application"@. 
+@getFileObject@ opens a file or url and loads the associated or persistent object in it:
+@getFileObject "spreadsheet.spd"@. 
+@coCreateInstance@ is the basic com way of creating components. It takes
+a CLSID, process context and IID to create an object: 
+@coCreateInstance clsidAgentServer Nothing LocalProcess iidIAgent@.
+-}
+
+coCreateObject :: ProgID -> IID (IUnknown a) -> IO (IUnknown a)
+coCreateObject progid iid = do
+    clsid  <- clsidFromProgID progid
+    coCreateInstance clsid Nothing AnyProcess iid
+
+{-
+Get Object from File \& ProgID.
+-}
+coGetFileObject :: String -> ProgID -> IID (IUnknown a) -> IO (IUnknown a)
+coGetFileObject ""    progid iid = coGetActiveObject progid iid
+coGetFileObject fname progid iid = do
+    pf <- coCreateObject progid iidIPersistFile
+    stackWideString fname $ \pfname -> do
+      persistfileLoad pf pfname 0
+      pf # queryInterface iid
+
+--Get Active Object.
+coGetActiveObject :: ProgID -> IID (IUnknown a) -> IO (IUnknown a)
+coGetActiveObject progid iid = do
+  clsid   <- clsidFromProgID progid
+  iface   <- primGetActiveObject clsid
+               `coOnFail` ("Could not connect to component '" ++ progid ++ "'")
+  iface # queryInterface iid
+
+primGetActiveObject :: CLSID -> IO (IUnknown a)
+primGetActiveObject clsid = do
+  clsid     <- marshallCLSID clsid
+  ppvObject <- allocOutPtr
+  hr        <- getActiveObject (castForeignPtr clsid) nullPtr ppvObject
+  doThenFree free (readIUnknown False{-finalise only-}) ppvObject
+
+
+--Bind to object via 'moniker string' / display name.
+coGetObject :: String -> IID (IUnknown a) -> IO (IUnknown a)
+coGetObject fname iid  = do
+   stackWideString fname $ \pfname -> do 
+      iid <- marshallIID iid
+      ppv <- bindObject pfname (castForeignPtr iid)
+      doThenFree free (readIUnknown False{-finalise only-}) ppv
+
+--COM initialize/uninitialize:
+
+coRun :: IO a -> IO a
+coRun io = do
+  coInitialize
+  v <-
+    catch io
+      (\ err -> do
+        when (isCoError err) (putMessage $ coGetErrorString err)
+        coUnInitialize
+        ioError err)
+  coUnInitialize
+  return v
+
+coPerformIO :: IO a -> IO a
+coPerformIO io =
+ catch io
+       ( \ err -> do 
+	    putMessage (coGetErrorString err)
+            ioError err 
+       )
+
+coUnsafePerformIO :: IO a -> a
+coUnsafePerformIO = unsafePerformIO . coPerformIO
+
+printMessage :: Show a => a -> IO ()
+printMessage x = putMessage (show x)
+
+putMessage :: String -> IO ()
+putMessage msg = 
+	stackString msg               $ \ _ m -> 
+	stackString "Haskell message" $ \ _ t -> 
+	Base.messageBox m t 0x40040
+	  {- To mere mortals, that's MB_OK | MB_ICONINFORMATION | MB_TOPMOST :-) -}
+
+messageBox :: String -> String -> Word32 -> IO ()
+messageBox msg title flg = 
+	stackString msg             $ \ _ m -> 
+	stackString title           $ \ _ t -> 
+	Base.messageBox m t flg
+
+outputDebugString :: String -> IO ()
+outputDebugString msg = primOutputDebugString ("haskell-com: " ++ msg ++ "\n")
+
+{-
+ Really belongs elsewhere...getting info of what kind of
+ platform we're on. 
+-}
+data OSVersionInfo 
+ = OSVersionInfo Word32 Word32 Word32
+
+isWindowsNT :: OSVersionInfo -> Bool
+isWindowsNT (OSVersionInfo _ _ 2{-VER_PLATFORM_WIN32_NT-}) = True
+isWindowsNT _ = False
+
+isWindows95 :: OSVersionInfo -> Bool
+isWindows95 (OSVersionInfo _ 0 1{-VER_PLATFORM_WIN32_WINDOWS-}) = True
+isWindows95 _ = False
+
+isWindows98 :: OSVersionInfo -> Bool
+isWindows98 (OSVersionInfo _ x 1{-VER_PLATFORM_WIN32_WINDOWS-}) = x /= 0
+isWindows98 _ = False
+
+versionInfo :: OSVersionInfo
+versionInfo = unsafePerformIO $ do
+  (j,n,d) <- primGetVersionInfo
+  return (OSVersionInfo j n d)
+
+{-
+Enumeration used by @comCreateInstance@ to specify execution
+context in which we'd like to component to be created
+(just use @AnyProcess@ if you're not fussed):
+-}
+
+data CLSCTX 
+ = CLSCTX_INPROC_SERVER 
+ | CLSCTX_INPROC_HANDLER
+ | CLSCTX_LOCAL_SERVER 
+ | CLSCTX_INPROC_SERVER16
+ | CLSCTX_REMOTE_SERVER
+ | CLSCTX_INPROC_HANDLER16
+ | CLSCTX_INPROC_SERVERX86
+ | CLSCTX_INPROC_HANDLERX86
+ | LocalProcess
+ | InProcess
+ | ServerProcess
+ | AnyProcess
+ deriving (Show)
+
+instance Enum CLSCTX where
+  fromEnum ctx =
+    case ctx of
+     CLSCTX_INPROC_SERVER -> 1
+     CLSCTX_INPROC_HANDLER -> 2
+     CLSCTX_LOCAL_SERVER -> 4
+     CLSCTX_INPROC_SERVER16 -> 8
+     CLSCTX_REMOTE_SERVER -> 16
+     CLSCTX_INPROC_HANDLER16 -> 32
+     CLSCTX_INPROC_SERVERX86 -> 64
+     CLSCTX_INPROC_HANDLERX86 -> 128
+     LocalProcess   -> localProcess
+     InProcess      -> inProcess
+     ServerProcess  -> serverProcess
+     AnyProcess     -> anyProcess
+
+  toEnum x =
+   case x of
+     1    -> CLSCTX_INPROC_SERVER
+     2    -> CLSCTX_INPROC_HANDLER
+     8    -> CLSCTX_INPROC_SERVER16
+     16   -> CLSCTX_REMOTE_SERVER
+     32   -> CLSCTX_INPROC_HANDLER16
+     64   -> CLSCTX_INPROC_SERVERX86
+     128  -> CLSCTX_INPROC_HANDLERX86
+     0x04 -> LocalProcess
+     0x0b -> InProcess
+     0x0d -> ServerProcess
+     4    -> CLSCTX_LOCAL_SERVER
+     _    -> AnyProcess
+
+
+localProcess    :: Int
+localProcess    = 0x04
+inProcess       :: Int
+inProcess       = 0x0b
+serverProcess   :: Int
+serverProcess   = 0x0d
+anyProcess      :: Int
+anyProcess      = 0x0f
+
+
+--VTable method invocation wrappers:
+
+invokeAndCheck :: (Ptr any -> Ptr b -> IO HRESULT) -> Int -> IUnknown a -> IO ()
+invokeAndCheck meth offset iptr = do
+  hr <- primInvokeItFO meth offset (marshallIUnknown iptr)
+  checkHR hr
+
+invokeIt :: (Ptr any -> Ptr c -> IO a) -> Int -> IUnknown b -> IO a
+invokeIt meth offset iptr = primInvokeItFO meth offset (marshallIUnknown iptr)
+
+{-
+Library provided stubs for IEnum* interfaces - the HaskellDirect
+knows how to generate code for these:
+-}
+enumNext :: Word32 -> (Ptr any -> IO a) -> Word32 -> IUnknown b -> IO [a]
+enumNext szof read_elt celt iptr = do
+    ptr     <- allocBytes (fromIntegral (celt * szof))
+    po      <- allocBytes (fromIntegral sizeofWord32)
+    invokeIt (\ methPtr ip -> primEnumNext methPtr ip celt ptr po) 3 iptr
+    elts_read <- readWord32 (castPtr po)
+    v         <- peek ((castPtr ptr) :: Ptr (Ptr a))
+    unmarshalllist szof 0 elts_read read_elt v
+
+enumSkip :: Word32 -> IUnknown a -> IO ()
+enumSkip count iptr = 
+   invokeIt (\ methPtr ip -> primEnumSkip methPtr ip count) 4 iptr
+
+enumReset :: IUnknown a -> IO ()
+enumReset iptr =
+   invokeIt (\ methPtr ip -> primEnumReset methPtr ip) 5 iptr
+
+enumClone :: IUnknown a -> IO (IUnknown b)
+enumClone iptr = do
+   ppv     <- allocOutPtr
+   invokeIt (\ methPtr ip -> primEnumClone methPtr ip ppv) 6 iptr
+   doThenFree free (readIUnknown False{-finalise only-}) ppv
+
+{-
+BSTRs were introduced by Automation, but their now used in non-Auto
+contexts.
+-}
+data BSTR = BSTR
+
+writeBSTR :: Ptr String -> String -> IO ()
+writeBSTR ptr str =
+  stackString str $ \_ pstr -> do
+    o_stringToBSTR <- prim_System_Win32_Com_Base_stringToBSTR (castPtr pstr) ptr
+    checkHR o_stringToBSTR
+
+--readBSTR :: Ptr BSTR -> IO String
+readBSTR :: Ptr (Ptr String) -> IO String
+readBSTR ptr = do
+  ptr' <- peek ptr
+  unmarshallBSTR ptr'
+
+unmarshallBSTR :: Ptr String -> IO String
+unmarshallBSTR bstr 
+  | bstr == nullPtr = return ""
+  | len == 0  = return ""
+  | otherwise = do
+     stackStringLen (4 + fromIntegral len) "" $ \ pstr -> do
+     bstrToStringLen (castPtr bstr) len (castPtr pstr)
+     unmarshallString pstr
+ where
+   len  = bstrLen (castPtr bstr)
+
+marshallBSTR :: String -> IO (Ptr String)
+marshallBSTR s = 
+  stackString s $ \ _ pstr -> do
+  ptr <- stringToBSTR (castPtr pstr)
+  x   <- peek (castPtr ptr)
+  free ptr
+  return x
+
+freeBSTR x 
+ | x == nullPtr = return ()
+ | otherwise    = P.freeBSTR x
+
+-- This type sometimes appear in IDL and tlbs, so
+-- to avoid having to depend on wtypes for it, let's
+-- simply define it here.
+type LPSTR = String
+
+coFree :: Ptr a -> IO ()
+coFree p = freeMemory p
+
+coAlloc :: Word32 -> IO (Ptr a)
+coAlloc sz = allocMemory sz
+
+type ProgID = String
+
+clsidFromProgID :: ProgID -> IO CLSID
+clsidFromProgID progid =
+   stackString progid $ \ _ pprogid -> do
+     pclsid  <- coAlloc sizeofCLSID
+     coOnFail (primCLSIDFromProgID pprogid (castPtr pclsid))
+     	      ("Component '" ++ progid ++ "' is unknown")
+     unmarshallCLSID True pclsid
+
+progIDFromCLSID :: CLSID -> IO ProgID
+progIDFromCLSID clsid = do
+   pclsid    <- marshallCLSID clsid
+   pwide     <- primProgIDFromCLSID (castForeignPtr pclsid)
+   (pstr,hr) <- wideToString (castPtr pwide)
+   checkHR hr
+   str       <- unmarshallString (castPtr pstr)
+   coFree pstr
+   coFree pwide
+   return str
+
+
+--Type libraries are identified by a GUID too:
+type LIBID = GUID
+
+mkLIBID :: String -> LIBID
+mkLIBID = mkGUID
+
+type LCID = Word32
+
+{-
+Representing interface pointers
+
+To represent a (COM) interface pointer, we use the type <tt/IUnknown/,
+which is parameterised over its interface:
+-}
+iidIUnknown :: IID (IUnknown ())
+iidIUnknown = mkIID "{00000000-0000-0000-C000-000000000046}"
+
+{-
+Equality of interface pointers is defined by the COM spec
+as being equality of IUnknown (pointers to) implementations.
+-}
+instance Eq (IUnknown_ a) where
+   iface1 == iface2    = coEqual (castIface iface1) (castIface iface2)
+
+castIface :: IUnknown a -> IUnknown b
+castIface (Unknown o) = Unknown o
+
+interfaceNULL :: IUnknown a
+interfaceNULL = unsafePerformIO (unmarshallIUnknown False nullPtr)
+
+isNullInterface :: IUnknown a -> Bool
+isNullInterface (Unknown ip)    = foreignPtrToPtr ip == nullPtr
+
+iidNULL :: IID ()
+iidNULL = mkIID "{00000000-0000-0000-0000-000000000000}"
+
+instance Show (IUnknown_ a) where
+  showsPrec _ iface   = 
+    shows "<interface pointer = " . 
+    shows (ifaceToAddr iface)     .
+    shows ">"
+
+{-
+Library provided stubs for IUnknown's methods:
+(derived from H/Direct output)
+-}
+queryInterface :: IID (IUnknown b) -> IUnknown a -> IO (IUnknown b)
+queryInterface riid iptr = do
+    ppvObject <- allocOutPtr
+    priid     <- marshallIID riid
+    invokeIt (\ methPtr ip -> primQI methPtr ip (castForeignPtr priid) ppvObject) 0 iptr
+    doThenFree free (readIUnknown False{-finalise only-}) ppvObject
+
+addRef :: IUnknown a -> IO Word32
+addRef iptr = invokeIt (\ methPtr ip -> primAddRef methPtr ip) 1 iptr
+
+release :: IUnknown a -> IO Word32
+release iptr = invokeIt (\ methPtr ip -> primRelease methPtr ip) 2 iptr
+
+withQueryInterface :: IID (IUnknown b)
+	           -> IUnknown a
+	           -> (IUnknown b -> IO c)
+	           -> IO c
+withQueryInterface iid unk action 
+ = bracket (queryInterface iid unk) release action
+
+--HDirect generated stub needed by @coGetObject@:
+persistfileLoad :: IPersistFile a -> Ptr Wchar_t -> Word32 -> IO ()
+persistfileLoad iptr pszFileName dwMode =
+    invokeIt (\ methPtr ip -> primPersistLoad methPtr ip pszFileName dwMode) 5 iptr
+
+--GUIDs:
+newtype GUID     = GUID (ForeignPtr ()) --(Pointer Guid)
+
+data Guid	 = Guid
+
+mkGUID :: String -> GUID
+mkGUID str = unsafePerformIO (stringToGUID str)
+
+newGUID :: IO GUID
+newGUID = do
+  pg  <- coAlloc sizeofGUID
+  ng  <- makeFO pg (castPtrToFunPtr finalFreeMemory)
+  primNewGUID ng
+  return (GUID ng)
+
+nullGUID :: GUID
+nullGUID = unsafePerformIO $ do
+  x <- primNullIID
+  p <- makeFO x (castPtrToFunPtr finalNoFree) --primNoFree
+  return (GUID p)
+
+marshallGUID :: GUID -> IO (ForeignPtr GUID)
+marshallGUID (GUID ptr) = return (castForeignPtr ptr)
+
+{-
+ A version of the GUID marshaller which copies rather
+ than hands back a pointer to the (immutable) GUID.
+-}
+copyGUID :: GUID -> IO (Ptr ())
+copyGUID (GUID ptr) = do
+    pg  <- coAlloc sizeofGUID
+    primCopyGUID ptr pg
+    return pg
+
+unmarshallGUID :: Bool -> Ptr GUID -> IO GUID
+unmarshallGUID finaliseMe ptr = do
+     -- ToDo: verify that HDirect *never ever* allocates and
+     --       stores a GUID in malloc()-space, but consistently
+     --       uses the COM task allocator. (Why? because the
+     --       finalizer below will tell the COM task allocator
+     --       to free the GUID once done with it)
+   f  <- makeFO ptr (castPtrToFunPtr $ if finaliseMe then finalFreeMemory else finalNoFree)
+   return (GUID f)
+
+writeGUID :: Ptr GUID -> GUID -> IO ()
+writeGUID ptr (GUID g) = poke (castPtr ptr) (foreignPtrToPtr g)
+
+readGUID :: Bool -> Ptr GUID -> IO GUID
+readGUID finaliseMe ptr = do
+--  ptr  <- peek ptr
+  unmarshallGUID finaliseMe ptr
+
+sizeofGUID  :: Word32
+sizeofGUID  = 16
+
+stringToGUID :: String -> IO GUID
+stringToGUID str =
+   stackWideString str $ \xstr -> do
+   pg <- coAlloc sizeofGUID
+   primStringToGUID xstr (castPtr pg)
+   unmarshallGUID True pg
+
+stringFromGUID :: GUID -> IO String
+stringFromGUID guid = do
+   pguid     <- marshallGUID guid
+   pwide     <- primGUIDToString (castForeignPtr pguid)
+   (pstr,hr) <- wideToString (castPtr pwide)
+   checkHR hr
+   str       <- unmarshallString (castPtr pstr)
+   coFree pstr
+   coFree pwide
+   return str
+
+guidToString :: GUID -> String
+guidToString ptr = unsafePerformIO (stringFromGUID ptr)
+
+{-
+Give the interface identifier(IID) a type parameter, so that when
+we come to define the Haskell type of <tt/IUnknown.QueryInterface(),/
+we can use the type checker to ensure that the IID passed to 
+<tt/QueryInterface/ agrees with the interface at which we're using
+the interface pointer that's returned (Hmm..this'll hopefully all become
+clearer.)
+-}
+
+newtype IID a	= IID GUID   deriving ( Eq )
+newtype CLSID	= CLSID GUID deriving ( Eq )
+
+mkIID   :: String -> IID a
+mkIID str   = IID (mkGUID str)
+
+mkCLSID :: String -> CLSID
+mkCLSID str = CLSID (mkGUID str)
+
+-- no need to provide marshallers for these, the IDL compiler
+-- knows that they're both represented by GUIDs.
+
+stringToIID :: String -> IID a
+stringToIID str = mkIID str
+
+stringToCLSID :: String -> CLSID
+stringToCLSID str = mkCLSID str
+
+iidToString :: IID a -> String
+iidToString (IID i) = guidToString i
+
+clsidToString :: CLSID -> String
+clsidToString (CLSID clsid) = guidToString clsid
+
+iidToGUID :: IID a -> GUID
+iidToGUID (IID g) = g
+
+castIID :: IID a -> IID b
+castIID (IID i) = IID i
+
+clsidToGUID :: CLSID -> GUID
+clsidToGUID (CLSID g) = g
+
+clsidToDisplayName :: CLSID  -> String
+clsidToDisplayName (CLSID g) = "clsid:" ++ tail (init (show g))
+
+guidToIID :: GUID -> IID a
+guidToIID g = IID g
+
+guidToCLSID :: GUID -> CLSID
+guidToCLSID g = CLSID g
+
+instance Show (IID a) where
+  showsPrec _ (IID i)  = showString (guidToString i)
+
+instance Show CLSID where
+  showsPrec _ (CLSID c)  = showString (guidToString c)
+
+instance Show GUID where
+  showsPrec _ guid     = showString (guidToString guid)
+
+instance Eq GUID where
+  (GUID x) == (GUID y) = unsafePerformIO $ do
+     return (isEqualGUID x y)
+
+marshallIID :: IID a -> IO (ForeignPtr (IID a))
+marshallIID (IID x) = marshallGUID x >>= return.castForeignPtr
+unmarshallIID :: Bool -> Ptr (IID a) -> IO (IID a)
+unmarshallIID finaliseMe x = do
+  i <- unmarshallGUID finaliseMe (castPtr x)
+  return (IID i)
+
+copyIID (IID x) = copyGUID x
+
+readIID :: Bool -> Ptr (Ptr (IID a)) -> IO (IID a)
+readIID finaliseMe ptr = do
+  a  <- peek ptr
+  unmarshallIID finaliseMe (castPtr a)
+
+writeIID :: Ptr (IID a) -> IID a -> IO ()
+writeIID ptr (IID i) = writeGUID (castPtr ptr) i
+
+--------
+
+marshallCLSID (CLSID x) = marshallGUID x
+
+unmarshallCLSID :: Bool -> Ptr CLSID -> IO CLSID
+unmarshallCLSID finaliseMe x = do
+  i <- unmarshallGUID finaliseMe (castPtr x)
+  return (CLSID i)
+
+copyCLSID (CLSID x) = copyGUID x
+
+readCLSID :: Bool -> Ptr (Ptr CLSID) -> IO CLSID
+readCLSID finaliseMe ptr = do
+  a  <- peek ptr
+  unmarshallCLSID finaliseMe (castPtr a)
+
+writeCLSID :: Ptr CLSID -> CLSID -> IO ()
+writeCLSID ptr (CLSID i) = writeGUID (castPtr ptr) i
+
+sizeofCLSID = sizeofGUID
+
+coInitialize :: IO ()
+coInitialize = comInitialize
+
+coUnInitialize :: IO ()
+coUnInitialize = comUnInitialize
+
+sizeofIID = sizeofGUID
+
+coEqual :: IUnknown a -> IUnknown b -> Bool
+coEqual ip1 ip2 = unsafePerformIO $ primComEqual (castIface ip1) (castIface ip2)
+
+--Interface pointer marshallers:
+
+-- marshallIUnknown is in Base.idl
+
+unmarshallIUnknown :: Bool -> Ptr b -> IO (IUnknown a)
+unmarshallIUnknown finaliseMe x = do
+   ip <- addrToIPointer finaliseMe x
+   case finaliseMe of
+     True | x /= nullPtr -> ip # addRef >> return ip
+     _    -> return ip
+
+unmarshallIUnknownFO :: ForeignPtr b -> IO (IUnknown a)
+unmarshallIUnknownFO i = return (Unknown (castForeignPtr i))
+  -- ToDo: I believe it is correct never to do an AddRef()
+  --       here, but double-check the spec.
+
+{-
+  addRefMe == True  => attach finaliser (which calls Release()), and
+  		       call addRef on i-pointer before returning.
+           == False => attach finaliser (which calls Release()) only.
+
+  The former case is used when you receive an i-pointer from the outside
+  world and want to copy a reference to it into the Haskell heap. This
+  does not include i-pointers you receive via [out] pointers when calling
+  a COM component method from Haskell, where it is the obligation of the
+  server filling in the [out] pointer to call addRef() for you.
+-}
+readIUnknown :: Bool -> Ptr b -> IO (IUnknown a)
+readIUnknown addRefMe x = do
+  ptr <- peek (castPtr x)
+  ip <- addrToIPointer True ptr
+  case addRefMe of
+     True | x /= nullPtr -> ip # addRef >> return ip
+     _    -> return ip
+
+writeIUnknown :: Bool -> Ptr (Ptr (IUnknown b)) -> IUnknown a -> IO ()
+writeIUnknown addRefMe x v = do
+   let a = ifaceToAddr v
+   when (addRefMe && a /= nullPtr)
+        (v # addRef >> return ())
+   writePtr x a
+
+{-
+@withObject@ applies every method in a list to an 
+object: @withObject genie [showUp, speak "hi", hide]@.
+@withMethod@ applies every argument in a list to a
+method: @genie # withMethod speak ["hello", "world"]@.
+-}
+
+withObject_ :: IUnknown a -> [IUnknown a -> IO b] -> IO ()
+withObject_ obj       = sequence_ .  map ( obj # ) 
+
+withMethod_ :: (a -> IUnknown b -> IO c) -> [a] -> IUnknown b -> IO ()
+withMethod_ method args obj = sequence_ $ map (\x -> obj # method x) args
+
+withObject :: IUnknown a -> [IUnknown a -> IO b] -> IO [b]
+withObject obj        = sequence . map ( obj # )
+
+withMethod :: (a -> IUnknown b -> IO c) -> [a] -> IUnknown b -> IO [c]
+withMethod method args obj = sequence $ map (\x -> obj # method x) args
+
+loadTypeLib :: String -> IO (IUnknown a)
+loadTypeLib fname = do
+    ptr <- allocOutPtr
+    stackWideString fname $ \pfname -> do
+      Base.loadTypeLib pfname ptr
+      doThenFree free (readIUnknown False{-finalise only-}) ptr
+
+loadRegTypeLib :: GUID -> Int -> Int -> Int -> IO (IUnknown a)
+loadRegTypeLib guid maj min lcid = do
+    ptr     <- allocOutPtr
+    p_guid  <- marshallGUID guid
+    Base.loadRegTypeLib (castForeignPtr p_guid)
+    			   (fromIntegral maj) (fromIntegral min)
+			   (fromIntegral lcid) ptr
+    doThenFree free (readIUnknown False{-finalise only-}) ptr
+
+queryPathOfRegTypeLib :: GUID
+		      -> Word16
+		      -> Word16
+		      -> IO String
+queryPathOfRegTypeLib gd maj min = do
+    pgd   <- marshallGUID gd
+    pbstr <- primQueryPathOfRegTypeLib (castForeignPtr pgd) maj min
+    if nullPtr == pbstr then
+        return ""
+      else do
+        str <- unmarshallBSTR (castPtr pbstr)
+	freeBSTR pbstr
+	return str
+
+createTypeLib :: String -> IO (IUnknown a) --(ICreateTypeLib a)
+createTypeLib nm = do
+   wstr <- stringToWide nm
+   pptr <- primCreateTypeLib 1{-SYS_WIN32-} wstr
+   doThenFree free (readIUnknown False{-finalise only-}) pptr
+
+loadTypeLibEx :: String -> Bool -> IO (IUnknown a)
+loadTypeLibEx path reg_tlb = do
+    let
+      {-
+        This Int is used to map onto the following enum
+
+         typedef enum tagREGKIND { REGKIND_DEFAULT, REGKIND_REGISTER, REGKIND_NONE };
+      -}
+     rkind :: Int
+     rkind
+      | reg_tlb   = 1
+      | otherwise = 2
+
+    out_ptr <- allocOutPtr
+    stackWideString path $ \pfname -> do
+      Base.loadTypeLibEx pfname (fromIntegral rkind) out_ptr
+      doThenFree free (readIUnknown False{-finalise only-}) out_ptr
+ System/Win32/Com/Automation.hs view
@@ -0,0 +1,1958 @@+{-# OPTIONS -#include "autoPrim.h" #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Win32.Com.Automation
+-- Copyright   :  (c) Daan Leijen <leijen@fwi.uva.nl>, 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 library for accessing OLE Automation objects.
+-- 
+-----------------------------------------------------------------------------
+module System.Win32.Com.Automation (
+      module System.Win32.Com,
+
+      IDispatch_, IDispatch, iidIDispatch, 
+
+      queryIUnknown, queryIDispatch,
+
+      createObject, getObject, getActiveObject, getFileObject,
+
+      Member, DISPID, getMemberID, VARIANT, sizeofVARIANT,
+      marshallVARIANT, unmarshallVARIANT, readVARIANT, writeVARIANT,
+      copyVARIANT, allocVARIANT,
+
+      VarIn, VarRes, ArgIn, ArgInOut, ArgOut, ArgRes,
+
+      Variant(..), inoutVariant, outVariant,
+
+      defaultEmpty, inEmpty, resEmpty, inoutEmpty, outEmpty, inNoArg,
+      defaultInt, inInt, resInt, inoutInt, outInt,
+      defaultInt8, inInt8, resInt8, inoutInt8, outInt8,
+      defaultInt16, inInt16, resInt16, inoutInt16, outInt16,
+      defaultInt32, inInt32, resInt32, inoutInt32, outInt32,
+      defaultInt64, inInt64, resInt64, inoutInt64, outInt64,
+      defaultInteger, inInteger, resInteger, inoutInteger, outInteger,
+      defaultHRESULT, inHRESULT, resHRESULT, inoutHRESULT, outHRESULT,
+      defaultWord, inWord, resWord, inoutWord, outWord,
+      defaultWord8, inWord8, resWord8, inoutWord8, outWord8,
+      defaultWord16, inWord16, resWord16, inoutWord16, outWord16,
+      defaultWord32, inWord32, resWord32, inoutWord32, outWord32,
+      defaultWord64, inWord64, resWord64, inoutWord64, outWord64,
+      defaultBool, inBool, resBool, inoutBool, outBool,
+      defaultByte, inByte, resByte, inoutByte, outByte,
+      defaultChar, inChar, resChar, inoutChar, outChar,
+      defaultFloat, inFloat, resFloat, inoutFloat, outFloat,
+      defaultDouble, inDouble, resDouble, inoutDouble, outDouble,
+      defaultString, inString, resString, inoutString, outString,
+      defaultIUnknown, inIUnknown, resIUnknown, inoutIUnknown, outIUnknown,
+      defaultIDispatch, inIDispatch, resIDispatch, inoutIDispatch, outIDispatch,
+      defaultDate, inDate, resDate, inoutDate, outDate, Date,
+      defaultError, inError, resError, inoutError, outError,
+      defaultMaybe, inMaybe, resMaybe, inoutMaybe, outMaybe, inOptional,
+      defaultCurrency, inCurrency, resCurrency, inoutCurrency, outCurrency, Currency,
+      defaultSafeArray, inSafeArray, resSafeArray, inoutSafeArray, outSafeArray, SafeArray, mkSafeArray,
+      defaultEnum, inEnum, resEnum, inoutEnum, outEnum, vtTypeEnum,
+      inHaskellValue, unsafeResHaskellValue, unsafeOutHaskellValue,
+      defaultSqlNull, inSqlNull, resSqlNull, inoutSqlNull, outSqlNull,
+      SqlNull(..),
+     
+      inGUID, outGUID,
+
+      inDefaultValue, noInArg, 
+
+      propertyGet, propertySet, propertySetGet,
+      propertyGet2, propertyGet3, propertyGet4,
+      propertyGetID, propertySetID, propertySetGetID,
+      propertyGet2ID, propertyGet3ID, propertyGet4ID,
+
+      function1, function2, function3, function4, function5, function6, 
+      functionID1, functionID2, functionID3, functionID4, functionID5, functionID6,
+
+      method0, method1, method2, method3, method4, method5, method6, method7, method8,
+      methodID0, methodID1, methodID2, methodID3, methodID4,
+      methodID5, methodID6, methodID7, methodID8,
+
+      unmarshallVariants0, unmarshallVariants1,
+      unmarshallVariants2, unmarshallVariants3,
+      unmarshallVariants4, unmarshallVariants5,
+      unmarshallVariants6, unmarshallVariants7,
+      unmarshallVariants8,
+
+      readVariants0, readVariants1,
+      readVariants2, readVariants3,
+      readVariants4, readVariants5,
+      readVariants6, readVariants7,
+      readVariants8,
+
+      method_0_0, method_1_0, method_2_0, method_3_0, method_4_0,
+      method_0_1, method_1_1, method_2_1, method_3_1, method_4_1,
+      method_0_2, method_1_2, method_2_2, method_3_2, method_4_2,
+
+      function_0_1, function_1_1, function_2_1, function_3_1, function_4_1,
+      function_0_2, function_1_2, function_2_2, function_3_2, function_4_2,
+
+      propertyGet_0, propertyGet_1, propertyGet_2, propertyGet_3, propertyGet_4,
+      propertySet_1, propertySet_2, propertySet_3, propertySet_4,
+
+      invokePropertyGet, invokePropertySet,
+      invokeMethod, invokeFunction,
+
+      enumVariants,
+      
+{- BEGIN_GHC_ONLY
+      marshallCurrency, unmarshallCurrency,
+      readCurrency, writeCurrency,
+   END_GHC_ONLY -}
+      sizeofCurrency,
+      
+      VARENUM(..),
+      marshallVARENUM, unmarshallVARENUM,
+      readVARENUM, writeVARENUM,
+      sizeofVARENUM, 
+      
+      sizeofVARIANT_BOOL,
+      marshallVARIANT_BOOL, unmarshallVARIANT_BOOL,
+      readVARIANT_BOOL, writeVARIANT_BOOL,
+      vARIANT_TRUE, vARIANT_FALSE,
+      
+      marshallVariant, unmarshallVariant,
+      readVariant, writeVariant,
+      
+      readVarEnum, 
+      readVarInt, 
+      readVarFloat,
+      readVarDouble,
+      readVarString,
+      readVarBool
+
+      , marshallSafeArray
+      , unmarshallSafeArray
+      , writeSafeArray
+      , readSafeArray
+      , freeSafeArray
+      , readSA
+      
+      , clockTimeToDate    -- :: Time.ClockTime  -> IO Date
+    ) where
+
+import System.Win32.Com.HDirect.HDirect as HDirect
+import IO          ( ioeGetErrorString )
+import Data.Char   ( chr, ord )
+import System.Time ( ClockTime(..) )
+
+import Data.Word ( Word8, Word16, Word32 )
+import Data.Int  ( Int32, Int16, Int8, Int64 )
+
+import System.Win32.Com
+import System.Win32.Com.Base  ( stringToBSTR )
+import System.Win32.Com.Exception ( dISP_E_UNKNOWNNAME, dISP_E_EXCEPTION )
+import System.Win32.Com.Automation.Base
+import System.Win32.Com.Automation.SafeArray ( addrToSAFEARRAY, marshallSAFEARRAY, readSAFEARRAY
+		 , writeSAFEARRAY, unmarshallSAFEARRAY, SAFEARRAY
+		 )
+import System.Win32.Com.HDirect.WideString
+import System.Win32.Com.HDirect.Pointer ( writeSeqAtDec, stackFrame, allocMemory, freeMemory )
+import Foreign.Ptr
+import Foreign.ForeignPtr  ( ForeignPtr )
+import Foreign.StablePtr   ( newStablePtr )
+import System.IO.Unsafe    ( unsafePerformIO )
+import Data.Bits
+
+{-
+The following creation functions are the VB equivalents in Haskell,
+notice the `unsafe' interface pointer return types used here. The
+interface pointers returned are compatible with the stubs for
+*any* IDispatch-derived interface. This makes it more convenient
+(saves the extra QI / type cast), but means that it is now
+possible to get run-time errors of the sort:
+'method X called but not supported'.
+-}
+
+createObject  :: ProgID -> IO (IDispatch a)
+createObject progid
+      = coCreateObject progid iidIDispatch_unsafe
+
+iidIDispatch_unsafe  = mkIID "{00020400-0000-0000-C000-000000000046}"
+
+getFileObject :: String -> ProgID -> IO (IDispatch a)
+getFileObject fname progid = coGetFileObject fname progid iidIDispatch_unsafe
+
+getActiveObject :: ProgID -> IO (IDispatch a)
+getActiveObject progid
+      = coGetActiveObject progid iidIDispatch_unsafe
+
+getObject :: String -> IO (IDispatch a)
+getObject fname = coGetObject fname iidIDispatch_unsafe
+
+{-
+The following functions are overloaded versions of the basic functions.
+The postfix "_n_m" means n input arguments and m results.
+-}
+method_0_0 name               = method0 name []
+method_1_0 name a1            = method0 name [inVariant a1] 
+method_2_0 name a1 a2         = method0 name [inVariant a1, inVariant a2]
+method_3_0 name a1 a2 a3      = method0 name [inVariant a1, inVariant a2, inVariant a3]
+method_4_0 name a1 a2 a3 a4   = method0 name [inVariant a1, inVariant a2, 
+                                              inVariant a3, inVariant a4]
+
+method_0_1 name               = method1 name [] outVariant
+method_1_1 name a1            = method1 name [inVariant a1] outVariant
+method_2_1 name a1 a2         = method1 name [inVariant a1, inVariant a2] outVariant
+method_3_1 name a1 a2 a3      = method1 name [inVariant a1, inVariant a2, 
+                                              inVariant a3] outVariant
+method_4_1 name a1 a2 a3 a4   = method1 name [inVariant a1, inVariant a2, 
+                                              inVariant a3, inVariant a4] outVariant
+
+method_0_2 name               = method2 name [] outVariant outVariant
+method_1_2 name a1            = method2 name [inVariant a1] outVariant outVariant
+method_2_2 name a1 a2         = method2 name [inVariant a1, inVariant a2] outVariant outVariant
+method_3_2 name a1 a2 a3      = method2 name [inVariant a1, inVariant a2, 
+                                              inVariant a3] outVariant outVariant
+method_4_2 name a1 a2 a3 a4   = method2 name [inVariant a1, inVariant a2, 
+                                              inVariant a3, inVariant a4] outVariant outVariant
+
+function_0_1 name               = function1 name [] outVariant
+function_1_1 name a1            = function1 name [inVariant a1] outVariant
+function_2_1 name a1 a2         = function1 name [inVariant a1, inVariant a2] outVariant
+function_3_1 name a1 a2 a3      = function1 name [inVariant a1, inVariant a2, 
+                                              inVariant a3] outVariant
+function_4_1 name a1 a2 a3 a4   = function1 name [inVariant a1, inVariant a2, 
+                                              inVariant a3, inVariant a4] outVariant
+
+function_0_2 name               = function2 name [] outVariant outVariant
+function_1_2 name a1            = function2 name [inVariant a1] outVariant outVariant
+function_2_2 name a1 a2         = function2 name [inVariant a1, inVariant a2] 
+                                                  outVariant outVariant
+function_3_2 name a1 a2 a3      = function2 name [inVariant a1, inVariant a2, 
+                                                  inVariant a3] outVariant outVariant
+function_4_2 name a1 a2 a3 a4   = function2 name [inVariant a1, inVariant a2, 
+                                                  inVariant a3, inVariant a4] 
+                                                  outVariant outVariant
+
+propertyGet_0 name              = propertyGet name [] outVariant
+propertyGet_1 name a1           = propertyGet name [inVariant a1] outVariant
+propertyGet_2 name a1 a2        = propertyGet name [inVariant a1, inVariant a2] outVariant
+propertyGet_3 name a1 a2 a3     = propertyGet name [inVariant a1, inVariant a2,
+                                                    inVariant a3] outVariant
+propertyGet_4 name a1 a2 a3 a4  = propertyGet name [inVariant a1, inVariant a2,
+                                                    inVariant a3, inVariant a4] outVariant
+
+propertySet_1 name a1           = propertySet name [inVariant a1]
+propertySet_2 name a1 a2        = propertySet name [inVariant a1, inVariant a2]
+propertySet_3 name a1 a2 a3     = propertySet name [inVariant a1, inVariant a2, inVariant a3]
+propertySet_4 name a1 a2 a3 a4  = propertySet name [inVariant a1, inVariant a2,
+                                                    inVariant a3, inVariant a4]
+
+-- Automation member functions or properties are identified
+-- by name or DISPID.
+
+type Member        = String
+-- type DISPID        = Int
+sizeDISPID         = 4
+
+getMemberID :: Member -> IDispatch a -> IO DISPID
+getMemberID name obj = do 
+   bstr        <- allocBSTR name
+   (dispid,hr) <- dispatchGetMemberID (castIface obj) bstr lcidNeutral
+                       `always` freeBSTR bstr
+   checkHR hr  `catch` (handleErr hr)
+   return dispid
+ where
+  handleErr hr err
+    | hr == dISP_E_UNKNOWNNAME =
+       coFail ("method '" ++ name ++ "' called but not supported by object")
+    | otherwise		      = errorMember name err
+
+
+{-
+Type definitions for marshalling functions. Variants are represented
+as functions that can read or write a value from or to a variant structure.
+-}
+type VarIn            = VARIANT -> IO ()
+type VarRes a         = VARIANT -> IO a
+
+type ArgIn a          = a -> VarIn
+type ArgRes a         = VarRes a
+type ArgOut a         = (VarIn,ArgRes a)
+type ArgInOut a b     = a -> ArgOut b
+
+{-
+For each type we define 5 functions; @defaultT@, @inT@,
+@resT@, @inoutT@, @outT@ where the last
+two functions are defined in terms of the first three.
+The @Variant@ class overloads these functions; if an
+argument can be more than one type, it will be overloaded
+and Haskell takes care of resolving the marshall function to use.
+We enable overlapping instance by providing explicit constructor functions
+in the class definition.
+-}
+
+--Input variants.
+
+class Variant a where
+  inVariant :: ArgIn a
+  inVarList :: ArgIn [a]
+  inVarIUnknown :: ArgIn (IUnknown a)
+
+  vtEltType :: a -> VARENUM
+
+  resVariant :: ArgRes a
+  defaultVariant :: a
+
+  resVarList :: ArgRes [a]
+  resVarIUnknown :: ArgRes (IUnknown a)
+  resVarIDispatch :: ArgRes (IDispatch a)
+
+--Overlapping instance for strings.
+
+instance Variant a => Variant [a] where
+  inVariant       = inVarList
+  resVariant      = resVarList
+  defaultVariant  = []
+
+
+instance Variant Char where
+  inVariant   = inChar
+  resVariant  = resChar
+  inVarList   = inString
+  resVarList  = resString
+  
+  vtEltType _ = VT_UI1
+
+-- Overlapping instance for @IDispatch a@ and @IUnknown ()@ variants.
+
+instance Variant a => Variant (IUnknown_ a) where
+  inVariant   = inVarIUnknown
+  resVariant  = resVarIUnknown
+  defaultVariant = defaultIUnknown
+
+  vtEltType _ = VT_UNKNOWN
+
+instance Variant (IDispatch_ a) where
+  inVarIUnknown  = inIDispatch
+  resVarIUnknown = resIDispatch
+
+  vtEltType _ = VT_DISPATCH
+
+instance Variant () where
+  inVarIUnknown   = inIUnknown
+  resVarIUnknown  = resIUnknown
+  resVarIDispatch = resIDispatch
+
+  inVariant      = inNoArg
+  resVariant     = resEmpty
+  defaultVariant = defaultEmpty
+
+  vtEltType _ = VT_ERROR
+
+--Normal instances.
+
+instance Variant Bool where
+  inVariant   = inBool
+  resVariant  = resBool
+  defaultVariant = defaultBool
+
+  vtEltType _ = VT_UI4
+
+instance Variant Int where
+  inVariant   = inInt
+  resVariant  = resInt
+  defaultVariant = defaultInt
+
+  vtEltType _ = VT_I4
+
+instance Variant Int32 where
+  inVariant   = inHRESULT
+  resVariant  = resHRESULT
+  defaultVariant = defaultHRESULT
+
+  vtEltType _ = VT_I4
+
+instance Variant Int16 where
+  inVariant   = inInt16
+  resVariant  = resInt16
+  defaultVariant = defaultInt16
+
+  vtEltType _ = VT_I2
+
+instance Variant Int8 where
+  inVariant   = inInt8
+  resVariant  = resInt8
+  defaultVariant = defaultInt8
+
+  vtEltType _ = VT_I1
+
+{- BEGIN_GHC_ONLY
+instance Variant Int64 where
+   END_GHC_ONLY -}
+{- BEGIN_NOT_FOR_GHC -}
+instance Variant Integer where
+{- END_NOT_FOR_GHC -}
+  inVariant   = inInt64
+  resVariant  = resInt64
+  defaultVariant = defaultInt64
+
+  vtEltType _ = VT_CY -- since VT_I8 isn't supported in VARIANTs.
+
+instance Variant Word8 where
+  inVariant   = inWord8
+  resVariant  = resWord8
+  defaultVariant = defaultWord8
+
+  vtEltType _ = VT_UI1
+
+instance Variant Word16 where
+  inVariant   = inWord16
+  resVariant  = resWord16
+  defaultVariant = defaultWord16
+
+  vtEltType _ = VT_UI2
+
+instance Variant Word32 where
+  inVariant   = inWord32
+  resVariant  = resWord32
+  defaultVariant = defaultWord32
+
+  vtEltType _ = VT_UI4
+
+{- BEGIN_GHC_ONLY
+instance Variant Word64 where
+  inVariant   = inWord64
+  resVariant  = resWord64
+  defaultVariant = defaultWord64
+
+  vtEltType _ = VT_DECIMAL  -- since VT_UI8 isn't supported in VARIANTs.
+   END_GHC_ONLY -}
+
+instance Variant Float where
+  inVariant   = inFloat
+  resVariant  = resFloat
+  defaultVariant = defaultFloat
+  vtEltType _ = VT_R4
+
+instance Variant Double where
+  inVariant   = inDouble
+  resVariant  = resDouble
+  defaultVariant = defaultDouble
+  vtEltType _ = VT_R8
+
+instance (Variant a) => Variant (Maybe a) where
+  inVariant      = inMaybe
+  resVariant     = resMaybe
+  defaultVariant = defaultMaybe
+  vtEltType mbx  = vtEltType (f mbx)
+		    where
+		      f :: Maybe a -> a
+		      f = undefined
+
+instance Variant (Ptr a) where
+  inVariant      = \ p y -> copyVARIANT y (castPtr p)
+  resVariant     = \ p -> return (castPtr p)
+  defaultVariant = nullPtr
+
+--Marshallers derived from instance methods:
+
+inoutVariant :: (Variant a, Variant b) => ArgInOut a b
+inoutVariant x        = (inVariant x,resVariant)
+
+inoutVariant' :: (Variant a) => ArgInOut a a
+inoutVariant' = inoutVariant
+
+outVariant :: (Variant a) => ArgOut a
+outVariant            = (inoutVariant' defaultVariant)
+
+inDefaultValue :: VarIn -> ArgIn a -> ArgIn a
+inDefaultValue varin_def argin = \ val var -> do
+  argin val var
+  vt <- readVarEnum var
+  case vt of -- to avoid having to define Eq..
+    VT_ERROR -> do
+      primVARIANTClear var
+      varin_def var
+    _ -> return ()
+
+defaultMaybe :: Variant a => Maybe a
+defaultMaybe = Nothing
+
+inOptional :: VarIn -> ArgIn a -> ArgIn (Maybe a)
+inOptional varin_def argin = \val var -> do
+   case val of
+     Nothing -> varin_def var
+     Just v  -> argin v var
+
+inMaybe :: Variant a => ArgIn (Maybe a)
+inMaybe Nothing  = inEmpty ()
+inMaybe (Just x) = inVariant x
+
+resMaybe :: Variant a => ArgRes (Maybe a)
+resMaybe p = 
+  catch
+    (readVarError p >> return Nothing)
+    (\ _ -> fmap Just (resVariant p))
+
+inoutMaybe :: Variant a => ArgInOut (Maybe a) (Maybe a)
+inoutMaybe o       = (inMaybe o,resMaybe)
+
+outMaybe :: Variant a => (VarIn,ArgRes (Maybe a))
+outMaybe  = inoutMaybe defaultMaybe
+
+data SqlNull     = SqlNull
+
+defaultSqlNull  :: SqlNull
+defaultSqlNull   = SqlNull
+
+inSqlNull :: ArgIn SqlNull
+inSqlNull SqlNull p   = writeVarNull p
+
+resSqlNull :: ArgRes SqlNull
+resSqlNull p          = readVarNull p >> return SqlNull
+
+inoutSqlNull SqlNull  = (inSqlNull SqlNull,resSqlNull)
+outSqlNull            = inoutSqlNull defaultSqlNull
+
+--Haskell values (stable ptr's). 
+
+inHaskellValue :: ArgIn a
+inHaskellValue x p = do
+   stable <- newStablePtr x
+   writeVarStablePtr stable (castPtr p)
+
+unsafeResHaskellValue :: ArgRes a
+unsafeResHaskellValue p = do
+   stable <- readVarStablePtr p
+   deRefStablePtr stable
+
+unsafeOutHaskellValue  =
+  ( \ p -> writeVarStablePtr undefinedStablePtr p
+  , unsafeResHaskellValue
+  )
+
+undefinedStablePtr :: StablePtr a
+undefinedStablePtr = unsafePerformIO (newStablePtr undefined)
+
+--Convenience QIs - are they really used?
+
+queryIUnknown :: IID (IUnknown a) -> IUnknown () -> IO (IUnknown a)
+queryIUnknown          = queryInterface
+
+queryIDispatch :: IID (IUnknown a) -> IDispatch () -> IO (IUnknown a)
+queryIDispatch         = queryInterface
+
+--The basic marshalling functions for automation types.
+
+defaultEmpty :: ()
+defaultEmpty            = ()
+
+inNoArg :: ArgIn ()
+inNoArg i               = writeVarOptional
+
+inEmpty :: ArgIn ()
+inEmpty i               = writeVarEmpty
+
+noInArg :: VarIn
+noInArg = inEmpty ()
+
+resEmpty :: ArgRes ()
+resEmpty p              = return ()
+
+inoutEmpty e            = (inEmpty e,resEmpty)
+outEmpty                = inoutEmpty defaultEmpty
+
+inGUID :: ArgIn GUID
+inGUID g = inString (show g)
+
+inoutGUID i           = (inGUID i,resGUID)
+outGUID                = inoutGUID nullGUID
+
+resGUID :: ArgRes GUID
+resGUID p  = resString p >>= stringToGUID
+
+--Integers.
+
+defaultInt :: Int
+defaultInt            = 0
+
+inInt :: ArgIn Int
+inInt i               = writeVarInt (fromIntegral i)
+
+resInt :: ArgRes Int
+resInt p              = readVarInt p >>= return.fromIntegral
+
+inoutInt i            = (inInt i,resInt)
+outInt                = inoutInt defaultInt
+
+defaultInt8 :: Int8
+defaultInt8        = 0
+
+inInt8 :: ArgIn Int8
+inInt8 i           = writeVarInt (fromIntegral i)
+
+resInt8 :: ArgRes Int8
+resInt8 p          = readVarInt p >>= return.fromIntegral
+
+inoutInt8 i        = (inInt8 i,resInt8)
+outInt8            = inoutInt8 defaultInt8
+
+defaultInt16 :: Int16
+defaultInt16        = 0
+
+inInt16 :: ArgIn Int16
+inInt16 i           = writeVarInt (fromIntegral i)
+
+resInt16 :: ArgRes Int16
+resInt16 p          = readVarInt p >>= return.fromIntegral
+
+inoutInt16 i        = (inInt16 i,resInt16)
+outInt16            = inoutInt16 defaultInt16
+
+defaultInt32 :: Int32
+defaultInt32        = 0
+
+inInt32 :: ArgIn Int32
+inInt32 i           = writeVarInt i
+
+resInt32 :: ArgRes Int32
+resInt32 p          = readVarInt p >>= return
+
+inoutInt32 i        = (inInt32 i,resInt32)
+outInt32            = inoutInt32 defaultInt32
+
+defaultHRESULT = defaultInt32
+inHRESULT = inInt32
+resHRESULT = resInt32
+inoutHRESULT = inoutInt32
+outHRESULT   = outInt32
+
+{- BEGIN_GHC_ONLY
+defaultInt64 :: Int64
+   END_GHC_ONLY -}
+{- BEGIN_NOT_FOR_GHC -}
+defaultInt64 :: Integer
+{- END_NOT_FOR_GHC -}
+defaultInt64        = 0
+
+inInt64 :: ArgIn Currency
+inInt64 = inCurrency
+
+resInt64 :: ArgRes Currency
+resInt64 = resCurrency
+
+inoutInt64 i = (inInt64 i,resInt64)
+outInt64     = inoutInt64 defaultInt64
+
+defaultInteger = defaultInt64
+inInteger      = inInt64
+resInteger     = resInt64
+inoutInteger   = inoutInt64
+outInteger     = outInt64
+
+--Words
+
+defaultWord :: Int
+defaultWord            = 0
+
+inWord :: ArgIn Int
+inWord i               = writeVarInt (fromIntegral i)
+
+resWord :: ArgRes Int
+resWord p              = readVarInt p >>= return.fromIntegral
+
+inoutWord i            = (inInt i,resInt)
+outWord                = inoutInt defaultInt
+
+defaultWord8 :: Word8
+defaultWord8            = 0
+
+inWord8 :: ArgIn Word8
+inWord8 i               = writeVarWord (fromIntegral i)
+
+resWord8 :: ArgRes Word8
+resWord8 p              = readVarWord p >>= return.fromIntegral
+
+inoutWord8 i            = (inWord8 i,resWord8)
+outWord8                = inoutWord8 defaultWord8
+
+defaultWord16 :: Word16
+defaultWord16            = 0
+
+inWord16 :: ArgIn Word16
+inWord16 i               = writeVarWord (fromIntegral i)
+
+resWord16 :: ArgRes Word16
+resWord16 p              = readVarWord p >>= return.fromIntegral
+
+inoutWord16 i            = (inWord16 i,resWord16)
+outWord16                = inoutWord16 defaultWord16
+
+defaultWord32 :: Word32
+defaultWord32            = 0
+
+inWord32 :: ArgIn Word32
+inWord32 i               = writeVarWord i
+
+resWord32 :: ArgRes Word32
+resWord32 p              = readVarWord p
+
+inoutWord32 i            = (inWord32 i,resWord32)
+outWord32                = inoutWord32 defaultWord32
+
+{- BEGIN_GHC_ONLY
+defaultWord64 :: Word64
+   END_GHC_ONLY -}
+{- BEGIN_NOT_FOR_GHC -}
+defaultWord64 :: Integer
+{- END_NOT_FOR_GHC -}
+defaultWord64            = 0
+
+{- BEGIN_GHC_ONLY
+inWord64 :: ArgIn Word64
+   END_GHC_ONLY -}
+{- BEGIN_NOT_FOR_GHC -}
+inWord64 :: ArgIn Integer
+{- END_NOT_FOR_GHC -}
+inWord64 f  = 
+   let
+    (hi,lo) = toInteger f `divMod` (toInteger (maxBound :: Int) + 1)
+   in
+   writeVarWord64 (fromInteger hi) (fromInteger lo)
+
+{- BEGIN_GHC_ONLY
+resWord64 :: ArgRes Word64
+   END_GHC_ONLY -}
+{- BEGIN_NOT_FOR_GHC -}
+resWord64 :: ArgRes Integer
+{- END_NOT_FOR_GHC -}
+resWord64           = 
+   let
+    coerceW = fromIntegral
+    coerceI = fromIntegral
+    
+    readWord v = do
+      (hi,lo) <- readVarWord64 v
+      return (coerceW hi * (coerceI (maxBound :: Int) + 1) + coerceW lo)
+   in
+   readWord
+
+inoutWord64 i            = (inWord64 i,resWord64)
+outWord64                = inoutWord64 defaultWord64
+
+--Bytes (yeah, I know, the name of the type was a bit of a give-away :-)
+
+--type Byte = Char
+
+defaultByte :: Byte
+defaultByte            = 0
+
+inByte :: ArgIn Byte
+inByte i               = writeVarByte i
+
+resByte :: ArgRes Byte
+resByte                = readVarByte
+
+inoutByte i            = (inByte i,resByte)
+outByte                = inoutByte defaultByte
+
+defaultChar :: Char
+defaultChar            = '\0'
+
+inChar :: ArgIn Char
+inChar i               = writeVarByte (fromIntegral (ord i))
+
+resChar :: ArgRes Char
+resChar  p             = readVarByte p >>= \ x -> return (chr (fromIntegral x))
+
+inoutChar i            = (inChar i,resChar)
+outChar                = inoutChar defaultChar
+
+--Booleans.
+
+defaultBool :: Bool
+defaultBool            = False
+
+inBool :: ArgIn Bool
+inBool b               = writeVarBool b
+
+resBool :: ArgRes Bool
+resBool                = readVarBool
+
+inoutBool b            = (inBool b,resBool)
+outBool                = inoutBool defaultBool
+
+--Floats.
+
+defaultFloat :: Float
+defaultFloat           = 0.0
+
+inFloat :: ArgIn Float
+inFloat f              = writeVarFloat f
+
+resFloat :: ArgRes Float
+resFloat               = readVarFloat
+
+inoutFloat b           = (inFloat b,resFloat)
+outFloat               = inoutFloat defaultFloat
+
+--Doubles.
+
+defaultDouble :: Double
+defaultDouble           = 0.0
+
+inDouble :: ArgIn Double
+inDouble f              = writeVarDouble f
+
+resDouble :: ArgRes Double
+resDouble               = readVarDouble
+
+inoutDouble b           = (inDouble b,resDouble)
+outDouble               = inoutDouble defaultDouble
+
+--Dates.
+
+type Date = Double
+
+defaultDate :: Date
+defaultDate           = 0.0
+
+inDate :: ArgIn Date
+inDate f              = writeVarDouble f
+
+resDate :: ArgRes Date
+resDate               = readVarDouble
+
+inoutDate b           = (inDate b,resDate)
+outDate               = inoutDate defaultDate
+
+--
+-- clockTimeToDate relies on a non-standard implementation of Time,
+-- i.e., one which exports ClockTime non-abstractly.
+-- 
+clockTimeToDate :: ClockTime -> IO Date
+clockTimeToDate (TOD secs _) 
+  | secs > fromIntegral (maxBound :: Int) ||
+    secs < fromIntegral (minBound :: Int) = 
+    ioError (userError "Automation.clockTimeToDate: ClockTime out of range")
+  | otherwise = primClockToDate (fromIntegral secs)
+
+--Currency:
+
+type Currency 
+{- BEGIN_GHC_ONLY
+   = Int64
+   END_GHC_ONLY -}
+{- BEGIN_NOT_FOR_GHC -}
+   = Integer
+{- END_NOT_FOR_GHC -}
+
+defaultCurrency :: Currency
+defaultCurrency  = 0
+
+-- Note: the Int64/Integer is interpreted literally here,
+-- and no account of the implicit scaling that CURRENCY 
+-- does is taken into account. ToDo: fix.
+inCurrency :: ArgIn Currency
+inCurrency f  = 
+   let
+{- BEGIN_NOT_FOR_GHC -}
+    (hi,lo) = f `divMod` (toInteger (maxBound :: Int) + 1)
+{- END_NOT_FOR_GHC -}
+{- BEGIN_GHC_ONLY
+    (hi,lo) = f `divMod` (fromIntegral (maxBound :: Int) + 1)
+   END_GHC_ONLY -}
+   in
+   writeVarCurrency (fromIntegral (fromIntegral hi)) (fromIntegral (fromIntegral lo))
+
+
+resCurrency :: ArgRes Currency
+resCurrency           = 
+   let
+{- BEGIN_GHC_ONLY
+    coerceI = fromIntegral
+   END_GHC_ONLY -}
+{- BEGIN_NOT_FOR_GHC -}
+    coerceI = toInteger
+{- END_NOT_FOR_GHC -}
+    
+    readCur v = do
+      (hi,lo) <- readVarCurrency v
+      return (coerceI (fromIntegral hi) * (coerceI (maxBound :: Int) + 1) +
+	      coerceI (fromIntegral lo))
+   in
+   readCur
+
+inoutCurrency b       = (inCurrency b, resCurrency)
+outCurrency           = inoutCurrency defaultCurrency
+
+--Strings.
+
+defaultString :: String
+defaultString            = ""
+
+inString :: ArgIn String
+inString s p           = do 
+                           pbstr  <- nofreeAllocBSTR s
+                           writeVarString (castPtr pbstr) p
+
+resString :: ArgRes String
+resString p            = readTempVar readVarString p (\ p -> unmarshallBSTR (castPtr p))
+
+inoutString i            = (inString i,resString)
+outString                = inoutString defaultString
+
+--Unknown objects.
+
+defaultIUnknown :: IUnknown a
+defaultIUnknown          = interfaceNULL
+
+inIUnknown :: ArgIn (IUnknown a)
+inIUnknown u p
+  | isNullInterface u = return ()
+  | otherwise         = do 
+                             u # addRef
+                             writeVarUnknown (castIface u) p
+
+
+resIUnknown :: ArgRes (IUnknown a)
+resIUnknown p = 
+  readTempVar readVarUnknown p (unmarshallIUnknown True{-finalise-})
+
+inoutIUnknown d          = (inIUnknown d,resIUnknown)
+outIUnknown              = inoutIUnknown defaultIUnknown
+
+--Dispatch objects.
+
+defaultIDispatch :: IDispatch a
+defaultIDispatch          = interfaceNULL
+
+inIDispatch :: ArgIn (IDispatch a)
+inIDispatch d p
+  | isNullInterface d = return ()
+  | otherwise         = do 
+                             d # addRef
+                             writeVarDispatch (castIface d) p
+
+resIDispatch :: ArgRes (IDispatch a)
+resIDispatch p    = 
+   readTempVar readVarDispatch p (unmarshallIUnknown True{-finalise-})
+
+inoutIDispatch d  = (inIDispatch d,resIDispatch)
+outIDispatch      = inoutIDispatch defaultIDispatch
+
+--Error objects.
+
+defaultError :: Int32
+defaultError         = 0
+
+inError :: ArgIn Int32
+inError d p          = writeVarError d p
+
+resError :: ArgRes Int32
+resError p           = readVarError p
+
+inoutError d          = (inError d,resError)
+outError              = inoutError defaultError
+
+--Generic wrappers for Enum instances
+
+inEnum :: Enum a => ArgIn a
+inEnum e = inInt (fromEnum e)
+
+defaultEnum  :: Enum a => a
+defaultEnum  = toEnum 0
+
+resEnum      :: Enum a => ArgRes a
+resEnum p    = readVarInt p >>= return.toEnum.fromIntegral
+inoutEnum    :: Enum a => ArgInOut a a
+inoutEnum i  = (inEnum i,resEnum)
+outEnum      :: Enum a => ArgOut a
+outEnum      = inoutEnum defaultEnum
+vtTypeEnum   :: Enum a => a -> VARENUM
+vtTypeEnum _ = VT_I4
+
+{- Support for overlapping instances required
+   to compile this one - let's not demand that 
+   being supported for now.
+   
+   If you do uncomment this one, you probably
+   also want to invoke the IDL compiler with
+   -fno-variant-enum-instances.
+
+instance Enum a => Variant a where
+  inVariant   = inEnum
+  resVariant  = resEnum
+  defaultVariant = defaultEnum
+
+  vtEltType _ = VT_I4
+-}
+
+--Setting and Getting properties: @getVisible = propertyGet "Visible" [] outBool@.
+
+propertyGet :: Member -> [VarIn] -> ArgOut a -> IDispatch d -> IO a
+propertyGet member argsin argout obj
+      = do dispid <- obj # getMemberID member
+           propertyGetID dispid argsin argout obj
+
+propertyGet2 :: Member -> [VarIn] -> ArgOut a1 -> ArgOut a2 -> IDispatch d -> IO (a1,a2)
+propertyGet2 member argsin argout1 argout2 obj
+      = do dispid <- obj # getMemberID member
+           propertyGet2ID dispid argsin argout1 argout2 obj
+
+propertyGet3 :: Member -> [VarIn] -> ArgOut a1 -> ArgOut a2 -> ArgOut a3 -> IDispatch d -> IO (a1,a2,a3)
+propertyGet3 member argsin argout1 argout2 argout3 obj
+      = do dispid <- obj # getMemberID member
+           propertyGet3ID dispid argsin argout1 argout2 argout3 obj
+
+propertyGet4 :: Member -> [VarIn] -> ArgOut a1 -> ArgOut a2 -> ArgOut a3 -> ArgOut a4 -> IDispatch d -> IO (a1,a2,a3,a4)
+propertyGet4 member argsin argout1 argout2 argout3 argout4 obj
+      = do dispid <- obj # getMemberID member
+           propertyGet4ID dispid argsin argout1 argout2 argout3 argout4 obj
+
+propertySet :: Member -> [VarIn] -> IDispatch d -> IO ()
+propertySet member argsin obj
+      = do dispid <- obj # getMemberID member
+           propertySetID dispid argsin obj
+
+propertySetGet :: Member -> [VarIn] -> ArgOut a -> IDispatch d -> IO a
+propertySetGet member argsin argout obj
+      = do dispid <- obj # getMemberID member
+           propertySetGetID dispid argsin argout obj
+
+propertyGetID :: DISPID -> [VarIn] -> ArgOut a -> IDispatch d -> IO a
+propertyGetID dispid argsin (varin,argres) obj
+      = do p <- obj # invokePropertyGet dispid argsin [varin]
+           unmarshallVariants1 argres p
+
+propertyGet2ID :: DISPID -> [VarIn] -> ArgOut a1 -> ArgOut a2 -> IDispatch d -> IO (a1,a2)
+propertyGet2ID dispid argsin (varin1,argres1) (varin2,argres2) obj
+      = do p <- obj # invokePropertyGet dispid argsin [varin1,varin2]
+           unmarshallVariants2 argres1 argres2 p
+
+propertyGet3ID :: DISPID -> [VarIn] -> ArgOut a1 -> ArgOut a2 -> ArgOut a3 -> IDispatch d -> IO (a1,a2,a3)
+propertyGet3ID dispid argsin (varin1,argres1) (varin2,argres2) (varin3,argres3) obj
+      = do p <- obj # invokePropertyGet dispid argsin [varin1,varin2,varin3]
+           unmarshallVariants3 argres1 argres2 argres3 p
+
+propertyGet4ID :: DISPID -> [VarIn] -> ArgOut a1 -> ArgOut a2 -> ArgOut a3 -> ArgOut a4 -> IDispatch d -> IO (a1,a2,a3,a4)
+propertyGet4ID dispid argsin (varin1,argres1) (varin2,argres2) (varin3,argres3) (varin4,argres4) obj
+      = do p <- obj # invokePropertyGet dispid argsin [varin1,varin2,varin3,varin4]
+           unmarshallVariants4 argres1 argres2 argres3 argres4 p
+
+propertySetID :: DISPID -> [VarIn] -> IDispatch d -> IO ()
+propertySetID dispid argsin obj
+      = do p <- obj # invokePropertySet dispid argsin []
+           unmarshallVariants0 p
+
+propertySetGetID :: DISPID -> [VarIn] -> ArgOut a -> IDispatch d -> IO a
+propertySetGetID dispid argsin (varin,argres) obj
+      = do p <- obj # invokePropertySet dispid argsin [varin]
+           unmarshallVariants1 argres p
+
+{-
+Methods and functions are defined using @method@/@funtion@. The digit
+appended to the name gives the number of results.
+For example: @confirm msg  = function1 "Confirm" [inString msg] outBool@.
+-}
+
+method0 :: Member
+        -> [VarIn]
+	-> IDispatch i
+	-> IO ()
+method0 member args obj = do
+   dispid <- obj # getMemberID member
+   catchMethError member (methodID0 dispid args obj)
+
+method1 :: Member
+        -> [VarIn]
+	-> ArgOut a1
+	-> IDispatch i
+	-> IO a1
+method1 member args argout obj = do
+   dispid <- obj # getMemberID member
+   catchMethError member (methodID1 dispid args argout obj)
+
+method2 :: Member
+        -> [VarIn]
+	-> ArgOut a1
+	-> ArgOut a2
+	-> IDispatch i
+	-> IO (a1,a2)
+method2 member args argout1 argout2 obj = do
+   dispid <- obj # getMemberID member
+   catchMethError member (methodID2 dispid args argout1 argout2 obj)
+
+method3 :: Member
+        -> [VarIn]
+	-> ArgOut a1 -> ArgOut a2 -> ArgOut a3
+        -> IDispatch i -> IO (a1,a2,a3)
+method3 member args argout1 argout2 argout3 obj = do 
+    dispid <- obj # getMemberID member
+    catchMethError member (methodID3 dispid args argout1 argout2 argout3 obj)
+
+method4 :: Member
+        -> [VarIn]
+	-> ArgOut a1 -> ArgOut a2 
+	-> ArgOut a3 -> ArgOut a4
+        -> IDispatch i -> IO (a1,a2,a3,a4)
+method4 member args argout1 argout2 argout3 argout4 obj = do
+    dispid <- obj # getMemberID member
+    catchMethError member $
+      methodID4 dispid args argout1 argout2 argout3 argout4 obj
+
+method5 :: Member 
+        -> [VarIn]
+	-> ArgOut a1 -> ArgOut a2 -> ArgOut a3
+	-> ArgOut a4 -> ArgOut a5
+        -> IDispatch i -> IO (a1,a2,a3,a4,a5)
+method5 member args argout1 argout2 argout3 argout4 argout5 obj = do
+    dispid <- obj # getMemberID member
+    catchMethError member $
+      methodID5 dispid args argout1 argout2 argout3 argout4 argout5 obj
+
+method6 :: Member 
+        -> [VarIn]
+	-> ArgOut a1 -> ArgOut a2 -> ArgOut a3 
+	-> ArgOut a4 -> ArgOut a5 -> ArgOut a6
+        -> IDispatch i
+	-> IO (a1,a2,a3,a4,a5,a6)
+method6 member args argout1 argout2 argout3 argout4 argout5 argout6 obj = do
+    dispid <- obj # getMemberID member
+    catchMethError member $
+      methodID6 dispid args argout1 argout2 argout3
+                            argout4 argout5 argout6 obj
+
+method7 :: Member 
+        -> [VarIn]
+	-> ArgOut a1 -> ArgOut a2 -> ArgOut a3
+	-> ArgOut a4 -> ArgOut a5 -> ArgOut a6 -> ArgOut a7
+        -> IDispatch i -> IO (a1, a2, a3, a4, a5, a6, a7)
+method7 member args argout1 argout2 argout3 argout4 argout5 argout6 argout7 obj = do
+    dispid <- obj # getMemberID member
+    catchMethError member $
+          methodID7 dispid args argout1 argout2 argout3
+	                        argout4 argout5 argout6 argout7 obj
+
+method8 :: Member
+        -> [VarIn]
+	-> ArgOut a1 -> ArgOut a2 -> ArgOut a3
+	-> ArgOut a4 -> ArgOut a5 -> ArgOut a6
+	-> ArgOut a7 -> ArgOut a8
+        -> IDispatch i 
+	-> IO (a1, a2, a3, a4, a5, a6, a7, a8)
+method8 member args argout1 argout2 argout3 
+                    argout4 argout5 argout6 
+		    argout7 argout8 obj = do
+    dispid <- obj # getMemberID member
+    catchMethError member $
+      methodID8 dispid args argout1 argout2 argout3 
+                            argout4 argout5 argout6 
+			    argout7 argout8 obj
+
+
+--Methods invoked on DISPID.
+
+methodID0 :: DISPID
+          -> [VarIn]
+	  -> IDispatch i
+	  -> IO ()
+methodID0 dispid args obj = do
+   p <- obj # invokeMethod dispid args []
+   unmarshallVariants0 p
+
+methodID1 :: DISPID
+          -> [VarIn]
+	  -> ArgOut a1
+	  -> IDispatch i
+	  -> IO a1
+methodID1 dispid args (varin,argres) obj = do
+   p <- obj # invokeMethod dispid args [varin]
+   unmarshallVariants1 argres p
+
+methodID2 :: DISPID
+          -> [VarIn]
+          -> ArgOut a1 -> ArgOut a2
+	  -> IDispatch i
+	  -> IO (a1,a2)
+methodID2 dispid args (varin1,argres1) (varin2,argres2) obj = do
+   p <- obj # invokeMethod dispid args [varin1,varin2]
+   unmarshallVariants2 argres1 argres2 p
+
+methodID3 :: DISPID
+          -> [VarIn]
+          -> ArgOut a1 -> ArgOut a2 -> ArgOut a3
+	  -> IDispatch i
+	  -> IO (a1,a2,a3)
+methodID3 dispid args (varin1,argres1) (varin2,argres2) (varin3,argres3) obj = do
+   p <- obj # invokeMethod dispid args [varin1,varin2,varin3]
+   unmarshallVariants3 argres1 argres2 argres3 p
+
+methodID4 :: DISPID
+          -> [VarIn]
+          -> ArgOut a1 -> ArgOut a2 -> ArgOut a3
+	  -> ArgOut a4
+          -> IDispatch i
+	  -> IO (a1,a2,a3,a4)
+methodID4 dispid args (varin1,argres1) (varin2,argres2)
+                      (varin3,argres3) (varin4,argres4) obj = do
+   p <- obj # invokeMethod dispid args [varin1,varin2,varin3,varin4]
+   unmarshallVariants4 argres1 argres2 argres3 argres4 p
+
+methodID5 :: DISPID
+          -> [VarIn]
+          -> ArgOut a1 -> ArgOut a2 -> ArgOut a3
+	  -> ArgOut a4 -> ArgOut a5
+          -> IDispatch i 
+	  -> IO (a1,a2,a3,a4,a5)
+methodID5 dispid args (varin1,argres1) (varin2,argres2)
+                      (varin3,argres3) (varin4,argres4)
+		      (varin5,argres5) obj = do
+   p <- obj # invokeMethod dispid args [varin1,varin2,varin3,varin4,varin5]
+   unmarshallVariants5 argres1 argres2 argres3 argres4 argres5 p
+
+
+methodID6 :: DISPID
+          -> [VarIn]
+          -> ArgOut a1 -> ArgOut a2 -> ArgOut a3
+	  -> ArgOut a4 -> ArgOut a5 -> ArgOut a6
+          -> IDispatch i
+	  -> IO (a1,a2,a3,a4,a5,a6)
+methodID6 dispid args (varin1,argres1) (varin2,argres2)
+                      (varin3,argres3) (varin4,argres4)
+		      (varin5,argres5) (varin6,argres6) obj = do
+   p <- obj # invokeMethod dispid args [varin1,varin2,varin3,varin4,varin5,varin6]
+   unmarshallVariants6 argres1 argres2 argres3 argres4 argres5 argres6 p
+
+methodID7 :: DISPID
+          -> [VarIn]
+          -> ArgOut a1 -> ArgOut a2 -> ArgOut a3
+	  -> ArgOut a4 -> ArgOut a5 -> ArgOut a6
+	  -> ArgOut a7
+          -> IDispatch i 
+	  -> IO (a1,a2,a3,a4,a5,a6,a7)
+methodID7 dispid args (varin1,argres1) (varin2,argres2)
+                      (varin3,argres3) (varin4,argres4)
+		      (varin5,argres5) (varin6,argres6)
+		      (varin7,argres7) obj = do
+   p <- obj # invokeMethod dispid args [varin1,varin2,varin3,varin4,varin5,varin6,varin7]
+   unmarshallVariants7 argres1 argres2 argres3 argres4 argres5 argres6 argres7 p
+
+methodID8 :: DISPID
+          -> [VarIn]
+          -> ArgOut a1 -> ArgOut a2 -> ArgOut a3
+	  -> ArgOut a4 -> ArgOut a5 -> ArgOut a6
+	  -> ArgOut a7 -> ArgOut a8
+	  -> IDispatch i
+	  -> IO (a1,a2,a3,a4,a5,a6,a7,a8)
+methodID8 dispid args (varin1,argres1) (varin2,argres2)
+                      (varin3,argres3) (varin4,argres4)
+		      (varin5,argres5) (varin6,argres6)
+		      (varin7,argres7) (varin8,argres8) obj = do
+   p <- obj # invokeMethod dispid args [varin1,varin2,varin3,varin4,varin5,varin6,varin7,varin8]
+   unmarshallVariants8 argres1 argres2 argres3 argres4 argres5 argres6 argres7 argres8 p
+
+{-
+Functions. Of course @function0@ is missing. The difference with
+methods is that functions expect the last @out@ argument to be
+a result (@retval@) instead of a real @out@ argument.
+-}
+
+function1 :: Member
+          -> [VarIn]
+	  -> ArgOut a1
+	  -> IDispatch i
+	  -> IO a1
+function1 member args argout obj = do
+   dispid <- obj # getMemberID member
+   catchMethError member (functionID1 dispid args argout obj)
+
+function2 :: Member
+          -> [VarIn]
+	  -> ArgOut a1 -> ArgOut a2
+	  -> IDispatch i
+	  -> IO (a1,a2)
+function2 member args argout1 argout2 obj = do
+   dispid <- obj # getMemberID member
+   catchMethError member (functionID2 dispid args argout1 argout2 obj)
+
+function3 :: Member
+          -> [VarIn]
+	  -> ArgOut a1 -> ArgOut a2 -> ArgOut a3
+	  -> IDispatch i
+	  -> IO (a1,a2,a3)
+function3 member args argout1 argout2 argout3 obj = do
+   dispid <- obj # getMemberID member
+   catchMethError member (functionID3 dispid args argout1 argout2 argout3 obj)
+
+function4 :: Member
+          -> [VarIn]
+	  -> ArgOut a1 -> ArgOut a2 -> ArgOut a3
+	  -> ArgOut a4
+	  -> IDispatch i
+	  -> IO (a1,a2,a3,a4)
+function4 member args argout1 argout2 argout3 argout4 obj = do
+   dispid <- obj # getMemberID member
+   catchMethError member (functionID4 dispid args argout1 argout2 argout3 argout4 obj)
+
+function5 :: Member
+          -> [VarIn]
+	  -> ArgOut a1 -> ArgOut a2 -> ArgOut a3
+	  -> ArgOut a4 -> ArgOut a5
+	  -> IDispatch i
+	  -> IO (a1,a2,a3,a4,a5)
+function5 member args argout1 argout2 argout3 
+		      argout4 argout5 obj = do
+   dispid <- obj # getMemberID member
+   catchMethError member $
+     functionID5 dispid args argout1 argout2 argout3 argout4 argout5 obj
+
+function6 :: Member
+          -> [VarIn]
+	  -> ArgOut a1 -> ArgOut a2 -> ArgOut a3
+	  -> ArgOut a4 -> ArgOut a5 -> ArgOut a6
+	  -> IDispatch i
+	  -> IO (a1,a2,a3,a4,a5,a6)
+function6 member args argout1 argout2 argout3 
+		      argout4 argout5 argout6 obj = do
+   dispid <- obj # getMemberID member
+   catchMethError member $
+     functionID6 dispid args argout1 argout2 argout3 argout4 argout5 argout6 obj
+
+functionID1 :: DISPID
+            -> [VarIn]
+	    -> ArgOut a1
+	    -> IDispatch i
+	    -> IO a1
+functionID1 dispid args (varin,argres) obj = do
+   p <- obj # invokeFunction dispid args [varin]
+   unmarshallVariants1 argres p
+
+functionID2 :: DISPID
+            -> [VarIn]
+            -> ArgOut a1 -> ArgOut a2
+	    -> IDispatch i
+	    -> IO (a1,a2)
+functionID2 dispid args (varin1,argres1) (varin2,argres2) obj = do
+   p <- obj # invokeFunction dispid args [varin1,varin2]
+   unmarshallVariants2 argres1 argres2 p
+
+functionID3 :: DISPID
+            -> [VarIn]
+            -> ArgOut a1 -> ArgOut a2 -> ArgOut a3
+	    -> IDispatch i
+	    -> IO (a1,a2,a3)
+functionID3 dispid args (varin1,argres1) (varin2,argres2)
+                        (varin3,argres3) obj = do
+   p <- obj # invokeFunction dispid args [varin1,varin2,varin3]
+   unmarshallVariants3 argres1 argres2 argres3 p
+
+functionID4 :: DISPID
+            -> [VarIn]
+            -> ArgOut a1 -> ArgOut a2 -> ArgOut a3
+	    -> ArgOut a4 
+	    -> IDispatch i
+	    -> IO (a1,a2,a3,a4)
+functionID4 dispid args (varin1,argres1) (varin2,argres2)
+                        (varin3,argres3) (varin4,argres4) obj = do
+   p <- obj # invokeFunction dispid args [varin1,varin2,varin3,varin4]
+   unmarshallVariants4 argres1 argres2 argres3 argres4 p
+
+functionID5 :: DISPID
+            -> [VarIn]
+            -> ArgOut a1 -> ArgOut a2 -> ArgOut a3
+	    -> ArgOut a4 -> ArgOut a5
+            -> IDispatch i
+	    -> IO (a1,a2,a3,a4,a5)
+functionID5 dispid args (varin1,argres1) (varin2,argres2)
+                        (varin3,argres3) (varin4,argres4)
+			(varin5,argres5) obj = do
+   p <- obj # invokeFunction dispid args [varin1,varin2,varin3,varin4,varin5]
+   unmarshallVariants5 argres1 argres2 argres3 argres4 argres5 p
+
+functionID6 :: DISPID
+            -> [VarIn]
+            -> ArgOut a1 -> ArgOut a2 -> ArgOut a3
+	    -> ArgOut a4 -> ArgOut a5 -> ArgOut a6
+            -> IDispatch i
+	    -> IO (a1,a2,a3,a4,a5,a6)
+functionID6 dispid args (varin1,argres1) (varin2,argres2)
+                        (varin3,argres3) (varin4,argres4)
+			(varin5,argres5) (varin6,argres6) obj = do
+   p <- obj # invokeFunction dispid args [varin1,varin2,varin3,varin4,varin5,varin6]
+   unmarshallVariants6 argres1 argres2 argres3 argres4 argres5 argres6 p
+
+--Error reporting:
+
+errorMember :: String -> IOError -> IO a
+errorMember member err
+      = coFail ("method '" ++ member ++ "': " ++ (coGetErrorString err))
+
+catchMethError :: Member -> IO a -> IO a
+catchMethError member act = catch act (errorMember member)
+
+--Unmarshall the @out@ arguments.
+
+unmarshallVariants0 p 
+      = readVariants0 p `always` freeMemVariants 0 p
+
+unmarshallVariants1 a p
+      = readVariants1 a p `always` freeMemVariants 1 p
+
+unmarshallVariants2   a b p
+      = readVariants2 a b p `always` freeMemVariants 2 p
+
+unmarshallVariants3   a b c p
+      = readVariants3 a b c p `always` freeMemVariants 3 p
+
+unmarshallVariants4   a b c d p
+      = readVariants4 a b c d p `always` freeMemVariants 4 p
+
+unmarshallVariants5   a b c d e p
+      = readVariants5 a b c d e p `always` freeMemVariants 5 p
+
+unmarshallVariants6   a b c d e f p
+      = readVariants6 a b c d e f p `always` freeMemVariants 6 p
+
+unmarshallVariants7   a b c d e f g p
+      = readVariants7 a b c d e f g p `always` freeMemVariants 7 p
+
+unmarshallVariants8   a b c d e f g h p
+      = readVariants8 a b c d e f g h p `always` freeMemVariants 8 p
+
+
+readVariants0 :: VARIANT -> IO ()
+readVariants0 p = return ()
+
+readVariants1 :: ArgRes a -> VARIANT  -> IO a
+readVariants1 f p = f p
+
+readVariants2 :: ArgRes a -> ArgRes b -> VARIANT  -> IO (a,b)
+readVariants2 f g p
+      = do y <- g p
+           x <- f (p `addNCastPtr` sizeofVARIANT)
+           return (x,y)
+
+readVariants3 :: ArgRes a -> ArgRes b -> ArgRes c
+                      -> VARIANT  -> IO (a,b,c)
+readVariants3 f g h p
+      = do z <- h p
+           y <- g (p `addNCastPtr` sizeofVARIANT)
+           x <- f (p `addNCastPtr` (2*sizeofVARIANT))
+           return (x,y,z)
+
+readVariants4 :: ArgRes a -> ArgRes b -> ArgRes c -> ArgRes d
+                      -> VARIANT  -> IO (a,b,c,d)
+readVariants4 f g h i p
+      = do z <- i p
+           y <- h (p `addNCastPtr` sizeofVARIANT)
+           x <- g (p `addNCastPtr` (2*sizeofVARIANT))
+           w <- f (p `addNCastPtr` (3*sizeofVARIANT))
+           return (w,x,y,z)
+
+readVariants5 :: ArgRes a -> ArgRes b -> ArgRes c -> ArgRes d -> ArgRes e
+                      -> VARIANT  -> IO (a,b,c,d,e)
+readVariants5 f g h i j p
+      = do z <- j p
+           y <- i (p `addNCastPtr` sizeofVARIANT)
+           x <- h (p `addNCastPtr` (2*sizeofVARIANT))
+           w <- g (p `addNCastPtr` (3*sizeofVARIANT))
+           v <- f (p `addNCastPtr` (4*sizeofVARIANT))
+           return (v,w,x,y,z)
+
+readVariants6 :: ArgRes a1 
+	      -> ArgRes a2
+	      -> ArgRes a3
+	      -> ArgRes a4
+	      -> ArgRes a5
+	      -> ArgRes a6
+              -> VARIANT
+	      -> IO (a1,a2,a3,a4,a5,a6)
+readVariants6 f1 f2 f3 f4 f5 f6 p
+      = do v6 <- f6 p
+           v5 <- f5 (p `addNCastPtr` sizeofVARIANT)
+           v4 <- f4 (p `addNCastPtr` (2*sizeofVARIANT))
+           v3 <- f3 (p `addNCastPtr` (3*sizeofVARIANT))
+           v2 <- f2 (p `addNCastPtr` (4*sizeofVARIANT))
+           v1 <- f1 (p `addNCastPtr` (5*sizeofVARIANT))
+           return (v1,v2,v3,v4,v5,v6)
+
+readVariants7 :: ArgRes a1 -> ArgRes a2 -> ArgRes a3 -> ArgRes a4 -> ArgRes a5 
+                      -> ArgRes a6 -> ArgRes a7
+                      -> VARIANT  -> IO (a1,a2,a3,a4,a5,a6,a7)
+readVariants7 f1 f2 f3 f4 f5 f6 f7 p
+      = do v7 <- f7 p
+           v6 <- f6 (p `addNCastPtr` sizeofVARIANT)
+           v5 <- f5 (p `addNCastPtr` (2*sizeofVARIANT))
+           v4 <- f4 (p `addNCastPtr` (3*sizeofVARIANT))
+           v3 <- f3 (p `addNCastPtr` (4*sizeofVARIANT))
+           v2 <- f2 (p `addNCastPtr` (5*sizeofVARIANT))
+           v1 <- f1 (p `addNCastPtr` (6*sizeofVARIANT))
+           return (v1,v2,v3,v4,v5,v6,v7)
+
+readVariants8:: ArgRes a1 -> ArgRes a2 -> ArgRes a3 -> ArgRes a4 -> ArgRes a5 
+                      -> ArgRes a6 -> ArgRes a7 -> ArgRes a8
+                      -> VARIANT  -> IO (a1,a2,a3,a4,a5,a6,a7,a8)
+readVariants8 f1 f2 f3 f4 f5 f6 f7 f8 p
+      = do v8 <- f8 p
+           v7 <- f7 (p `addNCastPtr` sizeofVARIANT)
+           v6 <- f6 (p `addNCastPtr` (2*sizeofVARIANT))
+           v5 <- f5 (p `addNCastPtr` (3*sizeofVARIANT))
+           v4 <- f4 (p `addNCastPtr` (4*sizeofVARIANT))
+           v3 <- f3 (p `addNCastPtr` (5*sizeofVARIANT))
+           v2 <- f2 (p `addNCastPtr` (6*sizeofVARIANT))
+           v1 <- f1 (p `addNCastPtr` (7*sizeofVARIANT))
+           return (v1,v2,v3,v4,v5,v6,v7,v8)
+
+{- UNUSED:
+unmarshallVariantList :: [ArgRes a] -> VARIANT  -> IO [a]
+unmarshallVariantList fls p = 
+   (go p fls []) `always` freeMemVariants len p
+  where
+    len = length fls
+
+    go p [] acc     = return acc
+    go p (f:fs) acc = do
+        v <- f p
+        go (p `addNCastPtr` sizeofVARIANT) fs (v:acc)
+-}
+
+{-
+@invokeMethod/Function@ and @propertyGet/Set@ all use the primitive
+@primInvokeMethod@.
+-}
+invokePropertyGet     = primInvokeMethod dispPROPERTYGET True
+invokePropertySet     = primInvokeMethod dispPROPERTYSET False
+invokeMethod          = primInvokeMethod dispMETHOD False
+invokeFunction        = primInvokeMethod dispMETHOD True
+
+--Some constants used with the invoke functions.
+
+type DispAction         = Word32
+
+dispMETHOD :: Word32
+dispMETHOD              = 1
+dispPROPERTYGET :: Word32
+dispPROPERTYGET         = 2
+dispPROPERTYSET :: Word32
+dispPROPERTYSET         = 4
+dispPROPERTYSETREF :: Word32
+dispPROPERTYSETREF      = 8
+
+lcidNeutral :: Word32
+lcidNeutral             = 0
+
+{-
+The primitive invokation mechanism. Exceptions are directed to the normal
+@coFail@ function.
+-}
+primInvokeMethod :: DispAction 
+	         -> Bool
+		 -> DISPID
+                 -> [VarIn] -> [VarIn]
+                 -> IDispatch d 
+		 -> IO (VARIANT)
+primInvokeMethod action isfunction dispid argin argout iptr
+      = let cargsout = fromIntegral (length argout)
+            cargs    = cargsout + fromIntegral (length argin)
+        in
+           stackFrame (fromIntegral (sizeofVARIANT * fromIntegral cargs)) $ \ pargs ->
+        do
+           pargout      <- allocMemory (fromIntegral $ sizeofVARIANT * fromIntegral cargsout)
+           let pargin   = pargs `addNCastPtr` (sizeofVARIANT * fromIntegral cargsout)
+
+           writeSeqAtDec (fromIntegral sizeofVARIANT) argin  pargin
+           writeSeqAtDec (fromIntegral sizeofVARIANT) argout pargout
+
+           (pinfo,hr) <- dispatchInvoke (castIface iptr)
+                              dispid lcidNeutral isfunction
+                              action (fromIntegral cargs) 
+			      cargsout
+                              pargs pargout
+
+           if (succeeded hr)
+            then return pargout
+            else if hr == dISP_E_EXCEPTION
+                  then do 
+                          pstr <- getExcepInfoMessage pinfo
+			  str  <- unmarshallString (castPtr pstr)
+			  coFree pstr
+                          freeExcepInfo pinfo
+                          freeMemory pinfo
+                          freeMemVariants cargsout pargout
+                          coFail str
+                  else do 
+                          putMessage "invoke failed"
+                          freeMemVariants cargsout pargout
+                          coFailHR hr
+
+--Some helper functions for @Variants@.
+
+readTempVar :: (VARIANT -> IO (Ptr (Ptr b), Ptr (VARIANT)))
+	    -> VARIANT
+	    -> (Ptr b -> IO d)
+	    -> IO d
+readTempVar io p f
+      = do (x,v) <- io p
+           x <- readPtr x  -- we always get a ty* back, so dereference it before using.
+           f x  `always` (freeVariants 1 (castPtr v) >> free v) 
+	       -- _don't_ use freeMemVariants, as it ends up
+	       -- calling freeMemory (==CoTaskMemFree()),
+	       -- which isn't right ('v' is allocated by malloc()).
+
+freeMemVariants count p = do
+      freeVariants count p
+      freeMemory p
+
+{-
+Marshall BSTR values. @allocBSTR@ is called @primAllocBSTR@
+since it doesn't take care of freeing the string. (If we
+just had true foreign objects: @mkPointer xbstr freeBSTR@.)
+-}
+
+allocBSTR :: String -> IO (Ptr String)
+allocBSTR s             = stackString s $ \ _ pstr -> do
+                            ptr <- stringToBSTR (castPtr pstr)
+			    readPtr ptr
+
+nofreeAllocBSTR :: String -> IO (Ptr String)
+nofreeAllocBSTR s       = stackString s $ \ _ pstr -> do
+                            ptr <- nofreeBstrFromString (castPtr pstr)
+			    return ptr
+--			    makePointer finalFreeBSTR ptr
+
+nofreeBstrFromString :: Ptr String -> IO (Ptr String)
+nofreeBstrFromString str = do
+   ptr <- stringToBSTR str
+   readPtr ptr
+
+data EnumVARIANT a      = EnumVARIANT
+type IEnumVARIANT a     = IUnknown (EnumVARIANT a)
+iidIEnumVARIANT :: IID (IEnumVARIANT ())
+iidIEnumVARIANT = mkIID "{00020404-0000-0000-C000-000000000046}"
+
+newEnum :: IDispatch a -> IO (Int, IEnumVARIANT b)
+newEnum ip = do
+  iunk  <- ip   # function1 "_NewEnum" [] outIUnknown
+  ienum <- iunk # queryInterface iidIEnumVARIANT
+  len   <- ip   # propertyGet "length" [] outInt
+  return (len, castIface ienum)
+  
+
+enumVariants :: Variant a => IDispatch b -> IO [a]
+enumVariants ip = do
+     (len, ienum) <- newEnum ip
+     enumNext (fromIntegral sizeofVARIANT) resVariant (fromIntegral len) ienum
+
+--Helpers
+
+always :: IO a -> IO () -> IO a
+always io action = do
+  x <- io `catch` (\ e -> action >> ioError e)
+  action
+  return x
+
+{- BEGIN_GHC_ONLY
+marshallCurrency = marshallInt64
+unmarshallCurrency = unmarshallInt64
+readCurrency = readInt64
+writeCurrency = writeInt64
+   END_GHC_ONLY -}
+sizeofCurrency = sizeofInt64
+
+data VARENUM
+ = VT_EMPTY
+ | VT_NULL
+ | VT_I2
+ | VT_I4
+ | VT_R4
+ | VT_R8
+ | VT_CY
+ | VT_DATE
+ | VT_BSTR
+ | VT_DISPATCH
+ | VT_ERROR
+ | VT_BOOL
+ | VT_VARIANT
+ | VT_UNKNOWN
+ | VT_DECIMAL
+ | VT_I1
+ | VT_UI1
+ | VT_UI2
+ | VT_UI4
+ | VT_I8
+ | VT_UI8
+ | VT_INT
+ | VT_UINT
+ | VT_VOID
+ | VT_HRESULT
+ | VT_PTR
+ | VT_SAFEARRAY
+ | VT_CARRAY
+ | VT_USERDEFINED
+ | VT_LPSTR
+ | VT_LPWSTR
+ | VT_FILETIME
+ | VT_BLOB
+ | VT_STREAM
+ | VT_STORAGE
+ | VT_STREAMED_OBJECT
+ | VT_STORED_OBJECT
+ | VT_BLOB_OBJECT
+ | VT_CF
+ | VT_CLSID
+ | VT_BSTR_BLOB
+ | VT_VECTOR
+ | VT_ARRAY
+ | VT_BYREF
+ | VT_RESERVED
+ | VT_ILLEGAL
+ | VT_ILLEGALMASKED
+ | VT_TYPEMASK
+   deriving ( Eq, Show )
+ 
+instance Enum VARENUM where
+  fromEnum vt = 
+   case vt of 
+     VT_EMPTY ->  0
+     VT_NULL ->  1
+     VT_I2 ->  2
+     VT_I4 ->  3
+     VT_R4 ->  4
+     VT_R8 ->  5
+     VT_CY ->  6
+     VT_DATE ->  7
+     VT_BSTR ->  8
+     VT_DISPATCH ->  9
+     VT_ERROR ->  10
+     VT_BOOL ->  11
+     VT_VARIANT ->  12
+     VT_UNKNOWN ->  13
+     VT_DECIMAL ->  14
+     VT_I1 ->  16
+     VT_UI1 ->  17
+     VT_UI2 ->  18
+     VT_UI4 ->  19
+     VT_I8 ->  20
+     VT_UI8 ->  21
+     VT_INT ->  22
+     VT_UINT ->  23
+     VT_VOID ->  24
+     VT_HRESULT ->  25
+     VT_PTR ->  26
+     VT_SAFEARRAY ->  27
+     VT_CARRAY ->  28
+     VT_USERDEFINED ->  29
+     VT_LPSTR ->  30
+     VT_LPWSTR ->  31
+     VT_FILETIME ->  64
+     VT_BLOB ->  65
+     VT_STREAM ->  66
+     VT_STORAGE ->  67
+     VT_STREAMED_OBJECT ->  68
+     VT_STORED_OBJECT ->  69
+     VT_BLOB_OBJECT ->  70
+     VT_CF ->  71
+     VT_CLSID ->  72
+     VT_BSTR_BLOB ->  4095
+     VT_VECTOR ->  4096
+     VT_ARRAY ->  8192
+     VT_BYREF ->  16384
+     VT_RESERVED ->  32768
+     VT_ILLEGAL ->  65535
+     VT_ILLEGALMASKED ->  4095
+     VT_TYPEMASK ->  4095
+
+  toEnum v =
+   case v of
+     0 -> VT_EMPTY
+     1 -> VT_NULL
+     2 -> VT_I2
+     3 -> VT_I4
+     4 -> VT_R4
+     5 -> VT_R8
+     6 -> VT_CY
+     7 -> VT_DATE
+     8 -> VT_BSTR
+     9 -> VT_DISPATCH
+     10 -> VT_ERROR
+     11 -> VT_BOOL
+     12 -> VT_VARIANT
+     13 -> VT_UNKNOWN
+     14 -> VT_DECIMAL
+     16 -> VT_I1
+     17 -> VT_UI1
+     18 -> VT_UI2
+     19 -> VT_UI4
+     20 -> VT_I8
+     21 -> VT_UI8
+     22 -> VT_INT
+     23 -> VT_UINT
+     24 -> VT_VOID
+     25 -> VT_HRESULT
+     26 -> VT_PTR
+     27 -> VT_SAFEARRAY
+     28 -> VT_CARRAY
+     29 -> VT_USERDEFINED
+     30 -> VT_LPSTR
+     31 -> VT_LPWSTR
+     64 -> VT_FILETIME
+     65 -> VT_BLOB
+     66 -> VT_STREAM
+     67 -> VT_STORAGE
+     68 -> VT_STREAMED_OBJECT
+     69 -> VT_STORED_OBJECT
+     70 -> VT_BLOB_OBJECT
+     71 -> VT_CF
+     72 -> VT_CLSID
+     4095 -> VT_BSTR_BLOB
+     4096 -> VT_VECTOR
+     8192 -> VT_ARRAY
+     16384 -> VT_BYREF
+     32768 -> VT_RESERVED
+     65535 -> VT_ILLEGAL
+     4095 -> VT_ILLEGALMASKED
+     4095 -> VT_TYPEMASK
+     _   
+       | v' .&. 26    == 26    -> VT_PTR   -- ho-hum.
+       | v' .&. 8192  == 8192  -> VT_ARRAY -- ho-hum.
+       | v' .&. 16384 == 16384 -> toEnum (v-16384) -- drop the VT_BYREF flag.
+       | otherwise -> error ("unmarshallVARENUM: illegal enum value " ++ show v)
+   where
+     v' = (fromIntegral v :: Int32)
+
+unmarshallVARENUM :: Int16 -> IO VARENUM
+unmarshallVARENUM v = return (toEnum (fromIntegral v))
+
+marshallVARENUM :: VARENUM -> IO Int16
+marshallVARENUM v = return (fromIntegral (fromEnum v))
+
+writeVARENUM :: Ptr Int16 -> VARENUM -> IO ()
+writeVARENUM = HDirect.writeenum16 marshallVARENUM
+
+readVARENUM :: Ptr Int16 -> IO VARENUM
+readVARENUM = HDirect.readenum16 unmarshallVARENUM
+
+sizeofVARENUM :: Word32
+sizeofVARENUM = sizeofInt16
+
+sizeofVARIANT_BOOL :: Word32
+sizeofVARIANT_BOOL = sizeofInt16
+
+marshallVARIANT_BOOL :: Bool -> IO Int16
+marshallVARIANT_BOOL True  = return minBound
+marshallVARIANT_BOOL False = return 0
+
+unmarshallVARIANT_BOOL :: Int16 -> IO Bool
+unmarshallVARIANT_BOOL 0  = return False
+unmarshallVARIANT_BOOL _  = return True
+
+writeVARIANT_BOOL :: Ptr Int16 -> Bool -> IO ()
+writeVARIANT_BOOL ptr v = marshallVARIANT_BOOL v >>= writeInt16 ptr
+
+readVARIANT_BOOL :: Ptr Int16 -> IO Bool
+readVARIANT_BOOL ptr = do
+  x <- readInt16 ptr
+  unmarshallVARIANT_BOOL x
+
+vARIANT_TRUE :: Int
+vARIANT_TRUE = -1
+
+vARIANT_FALSE :: Int
+vARIANT_FALSE = 0
+
+readVarEnum :: VARIANT -> IO VARENUM
+readVarEnum v = do
+  vt <- readVariantTag v
+  return (toEnum (fromIntegral vt))
+
+data SafeArray a = SA SAFEARRAY
+
+mkSafeArray :: (Variant a) => SAFEARRAY -> SafeArray a
+mkSafeArray s = SA s
+
+defaultSafeArray :: Variant a => SafeArray a
+defaultSafeArray = SA (addrToSAFEARRAY nullPtr)
+
+inSafeArray :: Variant a => ArgIn (SafeArray a)
+inSafeArray s  = inSafe' undefined s
+
+-- type hack.
+inSafe' :: Variant a => a -> ArgIn (SafeArray a)
+inSafe' b (SA s)  p = writeVarSAFEARRAY p s (fromIntegral (fromEnum (vtEltType b)))
+
+inSAFEARRAY :: ArgIn SAFEARRAY
+inSAFEARRAY s p = writeVarSAFEARRAY p s (fromIntegral (fromEnum VT_VARIANT))
+
+
+resSafeArray :: Variant a => ArgRes (SafeArray a)
+resSafeArray p       = resSafe' undefined p 
+
+resSafe' :: Variant a => a -> ArgRes (SafeArray a)
+resSafe' vt p = do
+	    x <- readVarSAFEARRAY (castPtr p) (fromIntegral (fromEnum (vtEltType vt)))
+	    s <- doThenFree free (readSAFEARRAY True) (castPtr x)
+	    return (SA s)
+
+resSAFEARRAY :: ArgRes SAFEARRAY
+resSAFEARRAY p       = do
+	    x <- readVarSAFEARRAY (castPtr p) (fromIntegral (fromEnum VT_VARIANT))
+	    doThenFree free (readSAFEARRAY True) (castPtr x)
+
+inoutSafeArray  :: (Variant a) => ArgInOut (SafeArray a) (SafeArray a)
+inoutSafeArray d          = (inSafeArray d,resSafeArray)
+outSafeArray :: Variant a => ArgOut (SafeArray a)
+outSafeArray              = inoutSafeArray defaultSafeArray
+
+freeSafeArray :: SafeArray a -> IO ()
+freeSafeArray (SA s) = return () -- it's a foreignObj..
+
+marshallSafeArray :: SafeArray a -> IO (ForeignPtr SAFEARRAY)
+marshallSafeArray (SA s) = marshallSAFEARRAY s
+
+unmarshallSafeArray :: Ptr a -> IO (SafeArray a)
+unmarshallSafeArray x = do
+  s <- unmarshallSAFEARRAY True (castPtr x)
+  return (SA s)
+
+writeSafeArray :: Ptr (SafeArray a) -> SafeArray a -> IO ()
+writeSafeArray ptr (SA s) = writeSAFEARRAY (castPtr ptr) s
+
+readSafeArray :: Variant a => Bool -> Ptr (SafeArray a) -> IO (SafeArray a)
+readSafeArray finaliseMe ptr = readSafeArray' finaliseMe ptr undefined
+
+readSafeArray' :: Variant a => Bool -> Ptr (SafeArray a) -> a -> IO (SafeArray a)
+readSafeArray' finaliseMe ptr x = do
+  xx <- readSA finaliseMe ptr (vtEltType x)
+  return (SA xx)
+
+readSA :: Bool -> Ptr (SafeArray a) -> VARENUM -> IO SAFEARRAY
+readSA finaliseMe ptr vt = do
+  x <- readVarSAFEARRAY (castPtr ptr) (fromIntegral (fromEnum vt))
+  doThenFree free (readSAFEARRAY finaliseMe) (castPtr x)
+
+instance Variant a => Variant (SafeArray a) where
+    inVariant  = inSafeArray
+    resVariant = resSafeArray   
+
+instance Variant SAFEARRAY where
+    inVariant  = inSAFEARRAY
+    resVariant = resSAFEARRAY
+
+marshallVariant :: Variant a => a -> IO VARIANT
+marshallVariant v = do
+  x <- allocMemory (fromIntegral sizeofVARIANT)
+  inVariant v (castPtr x)
+  return x
+
+writeVariant :: Variant a => VARIANT -> a -> IO ()
+writeVariant ptr v = inVariant v ptr
+
+readVariant :: Variant a => VARIANT -> IO a
+readVariant ptr = do
+  ptr' <- readPtr ptr
+  resVariant ptr'
+
+unmarshallVariant :: Variant a => VARIANT -> IO a
+unmarshallVariant ptr = resVariant ptr
+
+ System/Win32/Com/Automation/Base.hs view
@@ -0,0 +1,515 @@+{-# OPTIONS -#include "autoPrim.h" #-}
+-- Automatically generated by HaskellDirect (ihc.exe), snapshot 171208
+-- Created: 23:37 Pacific Standard Time, Wednesday 17 December, 2008
+-- Command line: -fno-qualified-names -fno-imports -fno-export-lists -fhs-to-c -fno-overload-variant -fout-pointers-are-not-refs -fsubtyped-interface-pointers -c System/Win32/Com/Automation/Base.idl -o System/Win32/Com/Automation/Base.hs
+
+module System.Win32.Com.Automation.Base where
+
+
+
+import System.Win32.Com (checkHR, marshallIUnknown, IUnknown, mkIID, IID, LCID)
+import System.Win32.Com.HDirect.HDirect (Ptr, allocBytes, marshallBool, readref, readStablePtr,
+                marshallPtr, readPtr, unmarshallref, trivialFree, doThenFree, free,
+                sizeofInt32, readInt32, unmarshallString, freeString, sizeofInt16, 
+                readInt16, sizeofDouble, readDouble, sizeofFloat, readFloat, Octet,
+		readBool, sizeofChar, readChar, unmarshallBool,
+		freeref, sizeofWord8, readWord8, sizeofWord32, readWord32,
+		StablePtr, sizeofPtr, readPtr, writePtr, sizeofForeignPtr )
+import System.Win32.Com.Automation.SafeArray ( SAFEARRAY, marshallSAFEARRAY, unmarshallSAFEARRAY, readSAFEARRAY, sizeofSAFEARRAY )
+import System.Win32.Com.HDirect.Pointer ( allocMemory )
+import System.IO.Unsafe (unsafePerformIO)
+import Data.Int  (Int32, Int16)
+import Data.Word (Word8, Word32)
+import Foreign.ForeignPtr ( ForeignPtr, withForeignPtr )
+import Foreign.Ptr
+
+{-
+#if defined(FOR_GHC)
+#define BEGIN_GHC_ONLY -}
+#define END_GHC_ONLY   {-
+#define BEGIN_NOT_FOR_GHC {-
+#define END_NOT_FOR_GHC -}
+#define ELSE_FOR_GHC -}-}
+#endif
+-}
+
+
+data VARIANT_ = VARIANT_
+type VARIANT = Ptr VARIANT_
+sizeofBSTR = sizeofPtr
+
+iidIDispatch :: IID (IDispatch ())
+iidIDispatch  = mkIID "{00020400-0000-0000-C000-000000000046}"
+
+sizeofVARIANT    :: Word32
+sizeofVARIANT         = 16
+
+marshallVARIANT   :: VARIANT -> IO VARIANT
+marshallVARIANT m = return m
+
+unmarshallVARIANT :: Ptr a -> IO VARIANT
+unmarshallVARIANT v = return (castPtr v)
+
+readVARIANT       :: Ptr VARIANT -> IO VARIANT
+readVARIANT ptr = 
+  readPtr ptr
+--  unmarshallVARIANT ptr
+
+writeVARIANT      :: Ptr VARIANT -> VARIANT -> IO ()
+writeVARIANT ptr v = writePtr ptr v
+
+copyVARIANT      :: VARIANT -> VARIANT -> IO ()
+copyVARIANT ptr v = do
+  primCopyVARIANT (castPtr ptr) (castPtr v)
+  -- ToDo: if the passed in variant has a finaliser
+  -- attached to it, this is the time to disable those.
+  -- It doesn't at the moment, though.
+
+allocVARIANT :: IO VARIANT
+allocVARIANT = do
+  x <- allocMemory (fromIntegral sizeofVARIANT)
+  variantInit x
+  return x
+
+{- BEGIN_GHC_ONLY 
+foreign import ccall "writeVarInt" writeVarStablePtr
+   END_GHC_ONLY -}
+{- BEGIN_NOT_FOR_GHC -}
+primitive writeVarStablePtr "prim_AutoPrim_writeVarInt"
+{- END_NOT_FOR_GHC -}
+     :: StablePtr a -> Ptr (StablePtr a) -> IO ()
+
+{- BEGIN_GHC_ONLY 
+foreign import ccall "readVarInt" prim_readVarStablePtr 
+   END_GHC_ONLY -}
+{- BEGIN_NOT_FOR_GHC -}
+primitive prim_readVarStablePtr "prim_AutoPrim_readVarInt"
+{- END_NOT_FOR_GHC -}
+     :: Ptr (StablePtr a) -> Ptr b -> IO Int32
+
+readVarStablePtr :: VARIANT -> IO (StablePtr a)
+readVarStablePtr p = do
+    i <- allocBytes (fromIntegral sizeofInt32)
+    o_readVarInt <- prim_readVarStablePtr (castPtr p) i
+    checkHR o_readVarInt
+    doThenFree (freeref trivialFree) (unmarshallref readStablePtr) i
+
+
+type DISPID = Int32
+type PEXCEPINFO = Ptr ()
+-- --------------------------------------------------
+-- 
+-- interface IDispatch
+-- 
+-- --------------------------------------------------
+data IDispatch_ a = IDispatch__
+                      
+type IDispatch a = IUnknown (IDispatch_ a)
+dispatchInvoke :: IDispatch a0
+               -> DISPID
+               -> LCID
+               -> Bool
+               -> Word32
+               -> Word32
+               -> Word32
+               -> VARIANT
+               -> VARIANT
+               -> IO (PEXCEPINFO, Int32)
+dispatchInvoke obj dispid lcid isfunction flags cargs cargsout args argsout =
+  do
+    info <- allocBytes (fromIntegral sizeofPtr)
+    obj <- marshallIUnknown obj
+    isfunction <- marshallBool isfunction
+    o_dispatchInvoke <- withForeignPtr obj (\ obj -> prim_System_Win32_Com_Automation_Base_dispatchInvoke obj dispid lcid isfunction flags cargs cargsout args argsout info)
+    info <- doThenFree free readPtr info
+    return (info, o_dispatchInvoke)
+
+foreign import ccall "dispatchInvoke" prim_System_Win32_Com_Automation_Base_dispatchInvoke :: Ptr (IDispatch a) -> Int32 -> Word32 -> Int32 -> Word32 -> Word32 -> Word32 -> VARIANT -> VARIANT -> Ptr (Ptr ()) -> IO Int32
+dispatchGetMemberID :: IDispatch a0
+                    -> Ptr String
+                    -> LCID
+                    -> IO (DISPID, Int32)
+dispatchGetMemberID obj name lcid =
+  do
+    dispid <- allocBytes (fromIntegral sizeofInt32)
+    obj <- marshallIUnknown obj
+    o_dispatchGetMemberID <- withForeignPtr obj (\ obj -> prim_System_Win32_Com_Automation_Base_dispatchGetMemberID obj name lcid dispid)
+    dispid <- doThenFree free readInt32 dispid
+    return (dispid, o_dispatchGetMemberID)
+
+foreign import ccall "dispatchGetMemberID" prim_System_Win32_Com_Automation_Base_dispatchGetMemberID :: Ptr (IDispatch a) -> Ptr String -> Word32 -> Ptr Int32 -> IO Int32
+freeExcepInfo :: PEXCEPINFO
+              -> IO ()
+freeExcepInfo einfo =
+  prim_System_Win32_Com_Automation_Base_freeExcepInfo einfo
+
+foreign import ccall "freeExcepInfo" prim_System_Win32_Com_Automation_Base_freeExcepInfo :: Ptr () -> IO ()
+getExcepInfoMessage :: PEXCEPINFO
+                    -> IO (Ptr Char)
+getExcepInfoMessage info =
+  prim_System_Win32_Com_Automation_Base_getExcepInfoMessage info
+
+foreign import ccall "getExcepInfoMessage" prim_System_Win32_Com_Automation_Base_getExcepInfoMessage :: Ptr () -> IO (Ptr Char)
+freeVariants :: Word32
+             -> VARIANT
+             -> IO ()
+freeVariants count p =
+  prim_System_Win32_Com_Automation_Base_freeVariants count
+                                                     p
+
+foreign import ccall "freeVariants" prim_System_Win32_Com_Automation_Base_freeVariants :: Word32 -> VARIANT -> IO ()
+readVariantTag :: VARIANT
+               -> IO Int32
+readVariantTag p =
+  prim_System_Win32_Com_Automation_Base_readVariantTag p
+
+foreign import ccall "readVariantTag" prim_System_Win32_Com_Automation_Base_readVariantTag :: VARIANT -> IO Int32
+variantInit :: VARIANT
+            -> IO ()
+variantInit p =
+  prim_System_Win32_Com_Automation_Base_variantInit p
+
+foreign import stdcall "VariantInit" prim_System_Win32_Com_Automation_Base_variantInit :: VARIANT -> IO ()
+writeVarShort :: Int16
+              -> VARIANT
+              -> IO ()
+writeVarShort i p =
+  prim_System_Win32_Com_Automation_Base_writeVarShort i
+                                                      p
+
+foreign import ccall "writeVarShort" prim_System_Win32_Com_Automation_Base_writeVarShort :: Int16 -> VARIANT -> IO ()
+readVarShort :: VARIANT
+             -> IO Int16
+readVarShort p =
+  do
+    i <- allocBytes (fromIntegral sizeofInt16)
+    o_readVarShort <- prim_System_Win32_Com_Automation_Base_readVarShort p i
+    checkHR o_readVarShort
+    doThenFree free readInt16 i
+
+foreign import ccall "readVarShort" prim_System_Win32_Com_Automation_Base_readVarShort :: VARIANT -> Ptr Int16 -> IO Int32
+writeVarInt :: Int32
+            -> VARIANT
+            -> IO ()
+writeVarInt i p =
+  prim_System_Win32_Com_Automation_Base_writeVarInt i
+                                                    p
+
+foreign import ccall "writeVarInt" prim_System_Win32_Com_Automation_Base_writeVarInt :: Int32 -> VARIANT -> IO ()
+readVarInt :: VARIANT
+           -> IO Int32
+readVarInt p =
+  do
+    i <- allocBytes (fromIntegral sizeofInt32)
+    o_readVarInt <- prim_System_Win32_Com_Automation_Base_readVarInt p i
+    checkHR o_readVarInt
+    doThenFree free readInt32 i
+
+foreign import ccall "readVarInt" prim_System_Win32_Com_Automation_Base_readVarInt :: VARIANT -> Ptr Int32 -> IO Int32
+writeVarWord :: Word32
+             -> VARIANT
+             -> IO ()
+writeVarWord i p =
+  prim_System_Win32_Com_Automation_Base_writeVarWord i
+                                                     p
+
+foreign import ccall "writeVarWord" prim_System_Win32_Com_Automation_Base_writeVarWord :: Word32 -> VARIANT -> IO ()
+readVarWord :: VARIANT
+            -> IO Word32
+readVarWord p =
+  do
+    i <- allocBytes (fromIntegral sizeofWord32)
+    o_readVarWord <- prim_System_Win32_Com_Automation_Base_readVarWord p i
+    checkHR o_readVarWord
+    doThenFree free readWord32 i
+
+foreign import ccall "readVarWord" prim_System_Win32_Com_Automation_Base_readVarWord :: VARIANT -> Ptr Word32 -> IO Int32
+writeVarFloat :: Float
+              -> VARIANT
+              -> IO ()
+writeVarFloat i p =
+  prim_System_Win32_Com_Automation_Base_writeVarFloat i
+                                                      p
+
+foreign import ccall "writeVarFloat" prim_System_Win32_Com_Automation_Base_writeVarFloat :: Float -> VARIANT -> IO ()
+readVarFloat :: VARIANT
+             -> IO Float
+readVarFloat p =
+  do
+    i <- allocBytes (fromIntegral sizeofFloat)
+    o_readVarFloat <- prim_System_Win32_Com_Automation_Base_readVarFloat p i
+    checkHR o_readVarFloat
+    doThenFree free readFloat i
+
+foreign import ccall "readVarFloat" prim_System_Win32_Com_Automation_Base_readVarFloat :: VARIANT -> Ptr Float -> IO Int32
+writeVarDouble :: Double
+               -> VARIANT
+               -> IO ()
+writeVarDouble i p =
+  prim_System_Win32_Com_Automation_Base_writeVarDouble i
+                                                       p
+
+foreign import ccall "writeVarDouble" prim_System_Win32_Com_Automation_Base_writeVarDouble :: Double -> VARIANT -> IO ()
+readVarDouble :: VARIANT
+              -> IO Double
+readVarDouble p =
+  do
+    i <- allocBytes (fromIntegral sizeofDouble)
+    o_readVarDouble <- prim_System_Win32_Com_Automation_Base_readVarDouble p i
+    checkHR o_readVarDouble
+    doThenFree free readDouble i
+
+foreign import ccall "readVarDouble" prim_System_Win32_Com_Automation_Base_readVarDouble :: VARIANT -> Ptr Double -> IO Int32
+writeVarString :: Ptr Char
+               -> VARIANT
+               -> IO ()
+writeVarString str p =
+  prim_System_Win32_Com_Automation_Base_writeVarString str
+                                                       p
+
+foreign import ccall "writeVarString" prim_System_Win32_Com_Automation_Base_writeVarString :: Ptr Char -> VARIANT -> IO ()
+readVarString :: VARIANT
+              -> IO (Ptr (Ptr Char), Ptr VARIANT)
+readVarString p =
+  do
+    pstr <- allocBytes (fromIntegral sizeofPtr)
+    w <- allocBytes (fromIntegral sizeofVARIANT)
+    o_readVarString <- prim_System_Win32_Com_Automation_Base_readVarString p pstr w
+    checkHR o_readVarString
+    return (pstr, w)
+
+foreign import ccall "readVarString" prim_System_Win32_Com_Automation_Base_readVarString :: VARIANT -> Ptr (Ptr Char) -> Ptr VARIANT -> IO Int32
+writeVarDispatch :: IDispatch a0
+                 -> VARIANT
+                 -> IO ()
+writeVarDispatch ip p =
+  do
+    ip <- marshallIUnknown ip
+    withForeignPtr ip (\ ip -> prim_System_Win32_Com_Automation_Base_writeVarDispatch ip p)
+
+foreign import ccall "writeVarDispatch" prim_System_Win32_Com_Automation_Base_writeVarDispatch :: Ptr (IDispatch a) -> VARIANT -> IO ()
+readVarDispatch :: VARIANT
+                -> IO (Ptr (Ptr ()), Ptr VARIANT)
+readVarDispatch p =
+  do
+    ip <- allocBytes (fromIntegral sizeofPtr)
+    w <- allocBytes (fromIntegral sizeofVARIANT)
+    o_readVarDispatch <- prim_System_Win32_Com_Automation_Base_readVarDispatch p ip w
+    checkHR o_readVarDispatch
+    return (ip, w)
+
+foreign import ccall "readVarDispatch" prim_System_Win32_Com_Automation_Base_readVarDispatch :: VARIANT -> Ptr (Ptr ()) -> Ptr VARIANT -> IO Int32
+writeVarOptional :: VARIANT
+                 -> IO ()
+writeVarOptional p =
+  prim_System_Win32_Com_Automation_Base_writeVarOptional p
+
+foreign import ccall "writeVarOptional" prim_System_Win32_Com_Automation_Base_writeVarOptional :: VARIANT -> IO ()
+writeVarError :: Int32
+              -> VARIANT
+              -> IO ()
+writeVarError err p =
+  prim_System_Win32_Com_Automation_Base_writeVarError err
+                                                      p
+
+foreign import ccall "writeVarError" prim_System_Win32_Com_Automation_Base_writeVarError :: Int32 -> VARIANT -> IO ()
+readVarError :: VARIANT
+             -> IO Int32
+readVarError p =
+  do
+    perr <- allocBytes (fromIntegral sizeofInt32)
+    o_readVarError <- prim_System_Win32_Com_Automation_Base_readVarError p perr
+    checkHR o_readVarError
+    doThenFree free readInt32 perr
+
+foreign import ccall "readVarError" prim_System_Win32_Com_Automation_Base_readVarError :: VARIANT -> Ptr Int32 -> IO Int32
+writeVarBool :: Bool
+             -> VARIANT
+             -> IO ()
+writeVarBool b p =
+  do
+    b <- marshallBool b
+    prim_System_Win32_Com_Automation_Base_writeVarBool b p
+
+foreign import ccall "writeVarBool" prim_System_Win32_Com_Automation_Base_writeVarBool :: Int32 -> VARIANT -> IO ()
+readVarBool :: VARIANT
+            -> IO Bool
+readVarBool p =
+  do
+    pb <- allocBytes (fromIntegral sizeofInt32)
+    o_readVarBool <- prim_System_Win32_Com_Automation_Base_readVarBool p pb
+    checkHR o_readVarBool
+    doThenFree free readBool pb
+
+foreign import ccall "readVarBool" prim_System_Win32_Com_Automation_Base_readVarBool :: VARIANT -> Ptr Int32 -> IO Int32
+writeVarUnknown :: IUnknown a0
+                -> VARIANT
+                -> IO ()
+writeVarUnknown ip p =
+  do
+    ip <- marshallIUnknown ip
+    withForeignPtr ip (\ ip -> prim_System_Win32_Com_Automation_Base_writeVarUnknown ip p)
+
+foreign import ccall "writeVarUnknown" prim_System_Win32_Com_Automation_Base_writeVarUnknown :: Ptr (IUnknown a) -> VARIANT -> IO ()
+readVarUnknown :: VARIANT
+               -> IO (Ptr (Ptr ()), Ptr VARIANT)
+readVarUnknown p =
+  do
+    ip <- allocBytes (fromIntegral sizeofPtr)
+    w <- allocBytes (fromIntegral sizeofVARIANT)
+    o_readVarUnknown <- prim_System_Win32_Com_Automation_Base_readVarUnknown p ip w
+    checkHR o_readVarUnknown
+    return (ip, w)
+
+foreign import ccall "readVarUnknown" prim_System_Win32_Com_Automation_Base_readVarUnknown :: VARIANT -> Ptr (Ptr ()) -> Ptr VARIANT -> IO Int32
+writeVarByte :: Octet
+             -> VARIANT
+             -> IO ()
+writeVarByte b p =
+  prim_System_Win32_Com_Automation_Base_writeVarByte b
+                                                     p
+
+foreign import ccall "writeVarByte" prim_System_Win32_Com_Automation_Base_writeVarByte :: Word8 -> VARIANT -> IO ()
+readVarByte :: VARIANT
+            -> IO Octet
+readVarByte p =
+  do
+    pb <- allocBytes (fromIntegral sizeofWord8)
+    o_readVarByte <- prim_System_Win32_Com_Automation_Base_readVarByte p pb
+    checkHR o_readVarByte
+    doThenFree free readWord8 pb
+
+foreign import ccall "readVarByte" prim_System_Win32_Com_Automation_Base_readVarByte :: VARIANT -> Ptr Word8 -> IO Int32
+writeVarEmpty :: VARIANT
+              -> IO ()
+writeVarEmpty p =
+  prim_System_Win32_Com_Automation_Base_writeVarEmpty p
+
+foreign import ccall "writeVarEmpty" prim_System_Win32_Com_Automation_Base_writeVarEmpty :: VARIANT -> IO ()
+writeVarNull :: VARIANT
+             -> IO ()
+writeVarNull p =
+  prim_System_Win32_Com_Automation_Base_writeVarNull p
+
+foreign import ccall "writeVarNull" prim_System_Win32_Com_Automation_Base_writeVarNull :: VARIANT -> IO ()
+readVarNull :: VARIANT
+            -> IO ()
+readVarNull p =
+  do
+    o_readVarNull <- prim_System_Win32_Com_Automation_Base_readVarNull p
+    checkHR o_readVarNull
+
+foreign import ccall "readVarNull" prim_System_Win32_Com_Automation_Base_readVarNull :: VARIANT -> IO Int32
+writeVarCurrency :: Int32
+                 -> Word32
+                 -> VARIANT
+                 -> IO ()
+writeVarCurrency hi lo p =
+  prim_System_Win32_Com_Automation_Base_writeVarCurrency hi
+                                                         lo
+                                                         p
+
+foreign import ccall "writeVarCurrency" prim_System_Win32_Com_Automation_Base_writeVarCurrency :: Int32 -> Word32 -> VARIANT -> IO ()
+readVarCurrency :: VARIANT
+                -> IO (Int32, Int32)
+readVarCurrency p =
+  do
+    hi <- allocBytes (fromIntegral sizeofInt32)
+    lo <- allocBytes (fromIntegral sizeofInt32)
+    o_readVarCurrency <- prim_System_Win32_Com_Automation_Base_readVarCurrency p hi lo
+    checkHR o_readVarCurrency
+    hi <- doThenFree free readInt32 hi
+    lo <- doThenFree free readInt32 lo
+    return (hi, lo)
+
+foreign import ccall "readVarCurrency" prim_System_Win32_Com_Automation_Base_readVarCurrency :: VARIANT -> Ptr Int32 -> Ptr Int32 -> IO Int32
+writeVarWord64 :: Word32
+               -> Word32
+               -> VARIANT
+               -> IO ()
+writeVarWord64 hi lo p =
+  prim_System_Win32_Com_Automation_Base_writeVarWord64 hi
+                                                       lo
+                                                       p
+
+foreign import ccall "writeVarWord64" prim_System_Win32_Com_Automation_Base_writeVarWord64 :: Word32 -> Word32 -> VARIANT -> IO ()
+readVarWord64 :: VARIANT
+              -> IO (Word32, Word32)
+readVarWord64 p =
+  do
+    hi <- allocBytes (fromIntegral sizeofWord32)
+    lo <- allocBytes (fromIntegral sizeofWord32)
+    o_readVarWord64 <- prim_System_Win32_Com_Automation_Base_readVarWord64 p hi lo
+    checkHR o_readVarWord64
+    hi <- doThenFree free readWord32 hi
+    lo <- doThenFree free readWord32 lo
+    return (hi, lo)
+
+foreign import ccall "readVarWord64" prim_System_Win32_Com_Automation_Base_readVarWord64 :: VARIANT -> Ptr Word32 -> Ptr Word32 -> IO Int32
+writeVarVariant :: VARIANT
+                -> VARIANT
+                -> IO ()
+writeVarVariant p1 p2 =
+  prim_System_Win32_Com_Automation_Base_writeVarVariant p1
+                                                        p2
+
+foreign import ccall "writeVarVariant" prim_System_Win32_Com_Automation_Base_writeVarVariant :: VARIANT -> VARIANT -> IO ()
+readVarVariant :: VARIANT
+               -> IO (Ptr VARIANT)
+readVarVariant p1 =
+  do
+    p2 <- allocBytes (fromIntegral sizeofVARIANT)
+    o_readVarVariant <- prim_System_Win32_Com_Automation_Base_readVarVariant p1 p2
+    checkHR o_readVarVariant
+    return (p2)
+
+foreign import ccall "readVarVariant" prim_System_Win32_Com_Automation_Base_readVarVariant :: VARIANT -> Ptr VARIANT -> IO Int32
+writeVarSAFEARRAY :: VARIANT
+                  -> SAFEARRAY
+                  -> Int32
+                  -> IO ()
+writeVarSAFEARRAY p1 p2 vt =
+  do
+    p2 <- marshallSAFEARRAY p2
+    withForeignPtr p2 (\ p2 -> prim_System_Win32_Com_Automation_Base_writeVarSAFEARRAY p1 p2 vt)
+
+foreign import ccall "writeVarSAFEARRAY" prim_System_Win32_Com_Automation_Base_writeVarSAFEARRAY :: VARIANT -> Ptr SAFEARRAY -> Int32 -> IO ()
+readVarSAFEARRAY :: VARIANT
+                 -> Int32
+                 -> IO (Ptr ())
+readVarSAFEARRAY p1 vt =
+  do
+    p2 <- allocBytes (fromIntegral sizeofPtr)
+    o_readVarSAFEARRAY <- prim_System_Win32_Com_Automation_Base_readVarSAFEARRAY p1 p2 vt
+    checkHR o_readVarSAFEARRAY
+    return (p2)
+
+foreign import ccall "readVarSAFEARRAY" prim_System_Win32_Com_Automation_Base_readVarSAFEARRAY :: VARIANT -> Ptr () -> Int32 -> IO Int32
+primCopyVARIANT :: VARIANT
+                -> VARIANT
+                -> IO ()
+primCopyVARIANT p1 p2 =
+  do
+    o_primCopyVARIANT <- prim_System_Win32_Com_Automation_Base_primCopyVARIANT p1 p2
+    checkHR o_primCopyVARIANT
+
+foreign import ccall "primCopyVARIANT" prim_System_Win32_Com_Automation_Base_primCopyVARIANT :: VARIANT -> VARIANT -> IO Int32
+primVARIANTClear :: VARIANT
+                 -> IO ()
+primVARIANTClear p1 =
+  do
+    o_primVARIANTClear <- prim_System_Win32_Com_Automation_Base_primVARIANTClear p1
+    checkHR o_primVARIANTClear
+
+foreign import ccall "primVARIANTClear" prim_System_Win32_Com_Automation_Base_primVARIANTClear :: VARIANT -> IO Int32
+primClockToDate :: Int32
+                -> IO Double
+primClockToDate ct =
+  do
+    pT <- allocBytes (fromIntegral sizeofDouble)
+    o_primClockToDate <- prim_System_Win32_Com_Automation_Base_primClockToDate ct pT
+    checkHR o_primClockToDate
+    doThenFree free readDouble pT
+
+foreign import ccall "primClockToDate" prim_System_Win32_Com_Automation_Base_primClockToDate :: Int32 -> Ptr Double -> IO Int32
+
+ System/Win32/Com/Automation/Connection.hs view
@@ -0,0 +1,277 @@+-- Automatically generated by HaskellDirect (ihc.exe), snapshot 171208
+-- Created: 23:37 Pacific Standard Time, Wednesday 17 December, 2008
+-- Command line: -fno-qualified-names -fappend-interface-short-name -c System/Win32/Com/Automation/Connection.idl -o System/Win32/Com/Automation/Connection.hs
+
+module System.Win32.Com.Automation.Connection
+       ( DWORD
+       , ULONG
+       , PCONNECTIONPOINT
+       , LPCONNECTIONPOINT
+       , getConnectionInterface
+       , getConnectionPointContainer
+       , advise
+       , unadvise
+       , enumConnections
+       , IConnectionPoint
+       , IConnectionPoint_
+       , iidIConnectionPoint
+       , PCONNECTIONPOINTCONTAINER
+       , LPCONNECTIONPOINTCONTAINER
+       , enumConnectionPoints
+       , findConnectionPoint
+       , IConnectionPointContainer
+       , IConnectionPointContainer_
+       , iidIConnectionPointContainer
+       , PENUMCONNECTIONS
+       , LPENUMCONNECTIONS
+       , CONNECTDATA(..)
+       , writeCONNECTDATA
+       , readCONNECTDATA
+       , sizeofCONNECTDATA
+       , TagCONNECTDATA
+       , PCONNECTDATA0
+       , TagCONNECTDATA0
+       , LPCONNECTDATA0
+       , next
+       , skip
+       , reset
+       , clone
+       , IEnumConnections
+       , IEnumConnections_
+       , iidIEnumConnections
+       , PENUMCONNECTIONPOINTS
+       , LPENUMCONNECTIONPOINTS
+       , nextECP
+       , skipECP
+       , resetECP
+       , cloneECP
+       , IEnumConnectionPoints
+       , IEnumConnectionPoints_
+       , iidIEnumConnectionPoints
+       ) where
+       
+import Prelude
+import Data.Int (Int32)
+import Data.Word (Word32)
+import Foreign.ForeignPtr (withForeignPtr)
+import Foreign.Ptr (Ptr)
+import System.Win32.Com (IUnknown, IID, mkIID, sizeofIID, 
+                         invokeAndCheck, unmarshallIID, readIUnknown, marshallIUnknown, 
+                         marshallIID, writeIUnknown, enumNext, enumSkip, enumReset, 
+                         enumClone)
+import System.Win32.Com.HDirect.HDirect (allocBytes, 
+                                         sizeofForeignPtr, free, doThenFree, sizeofWord32, 
+                                         readWord32, writeWord32, addNCastPtr)
+
+type DWORD = Word32
+type ULONG = Word32
+-- --------------------------------------------------
+-- 
+-- interface IConnectionPoint
+-- 
+-- --------------------------------------------------
+data IConnectionPoint_ a = IConnectionPoint__
+                             
+type IConnectionPoint a = IUnknown (IConnectionPoint_ a)
+iidIConnectionPoint :: IID (IConnectionPoint ())
+iidIConnectionPoint =
+  mkIID "{B196B286-BAB4-101A-B69C-00AA00341D07}"
+
+type PCONNECTIONPOINT = IConnectionPoint ()
+type LPCONNECTIONPOINT = IConnectionPoint ()
+getConnectionInterface :: IConnectionPoint a0
+                       -> IO (IID ())
+getConnectionInterface iptr =
+  do
+    piid <- allocBytes (fromIntegral sizeofIID)
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_Connection_getConnectionInterface methPtr iptr piid) 3 iptr
+    unmarshallIID True piid
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_Connection_getConnectionInterface :: Ptr () -> Ptr () -> Ptr (IID a) -> IO Int32
+getConnectionPointContainer :: IConnectionPoint a0
+                            -> IO (IConnectionPointContainer ())
+getConnectionPointContainer iptr =
+  do
+    ppCPC <- allocBytes (fromIntegral sizeofForeignPtr)
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_Connection_getConnectionPointContainer methPtr iptr ppCPC) 4 iptr
+    doThenFree free (readIUnknown False) ppCPC
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_Connection_getConnectionPointContainer :: Ptr () -> Ptr () -> Ptr (Ptr (IConnectionPointContainer a)) -> IO Int32
+advise :: IUnknown a1
+       -> IConnectionPoint a0
+       -> IO DWORD
+advise pUnkSink iptr =
+  do
+    pdwCookie <- allocBytes (fromIntegral sizeofWord32)
+    pUnkSink <- marshallIUnknown pUnkSink
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr pUnkSink (\ pUnkSink -> prim_System_Win32_Com_Automation_Connection_advise methPtr iptr pUnkSink pdwCookie)) 5 iptr
+    doThenFree free readWord32 pdwCookie
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_Connection_advise :: Ptr () -> Ptr () -> Ptr (IUnknown a) -> Ptr Word32 -> IO Int32
+unadvise :: DWORD
+         -> IConnectionPoint a0
+         -> IO ()
+unadvise dwCookie iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_Connection_unadvise methPtr iptr dwCookie)
+                 6
+                 iptr
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_Connection_unadvise :: Ptr () -> Ptr () -> Word32 -> IO Int32
+enumConnections :: IConnectionPoint a0
+                -> IO (IEnumConnections ())
+enumConnections iptr =
+  do
+    ppEnum <- allocBytes (fromIntegral sizeofForeignPtr)
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_Connection_enumConnections methPtr iptr ppEnum) 7 iptr
+    doThenFree free (readIUnknown False) ppEnum
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_Connection_enumConnections :: Ptr () -> Ptr () -> Ptr (Ptr (IEnumConnections a)) -> IO Int32
+-- --------------------------------------------------
+-- 
+-- interface IConnectionPointContainer
+-- 
+-- --------------------------------------------------
+data IConnectionPointContainer_ a = IConnectionPointContainer__
+                                      
+type IConnectionPointContainer a = IUnknown (IConnectionPointContainer_ a)
+iidIConnectionPointContainer :: IID (IConnectionPointContainer ())
+iidIConnectionPointContainer =
+  mkIID "{B196B284-BAB4-101A-B69C-00AA00341D07}"
+
+type PCONNECTIONPOINTCONTAINER = IConnectionPointContainer ()
+type LPCONNECTIONPOINTCONTAINER = IConnectionPointContainer ()
+enumConnectionPoints :: IConnectionPointContainer a0
+                     -> IO (IEnumConnectionPoints ())
+enumConnectionPoints iptr =
+  do
+    ppEnum <- allocBytes (fromIntegral sizeofForeignPtr)
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_Connection_enumConnectionPoints methPtr iptr ppEnum) 3 iptr
+    doThenFree free (readIUnknown False) ppEnum
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_Connection_enumConnectionPoints :: Ptr () -> Ptr () -> Ptr (Ptr (IEnumConnectionPoints a)) -> IO Int32
+findConnectionPoint :: IID a1
+                    -> IConnectionPointContainer a0
+                    -> IO (IConnectionPoint ())
+findConnectionPoint riid iptr =
+  do
+    ppCP <- allocBytes (fromIntegral sizeofForeignPtr)
+    riid <- marshallIID riid
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr riid (\ riid -> prim_System_Win32_Com_Automation_Connection_findConnectionPoint methPtr iptr riid ppCP)) 4 iptr
+    doThenFree free (readIUnknown False) ppCP
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_Connection_findConnectionPoint :: Ptr () -> Ptr () -> Ptr (IID a) -> Ptr (Ptr (IConnectionPoint a)) -> IO Int32
+-- --------------------------------------------------
+-- 
+-- interface IEnumConnections
+-- 
+-- --------------------------------------------------
+data IEnumConnections_ a = IEnumConnections__
+                             
+type IEnumConnections a = IUnknown (IEnumConnections_ a)
+iidIEnumConnections :: IID (IEnumConnections ())
+iidIEnumConnections =
+  mkIID "{B196B287-BAB4-101A-B69C-00AA00341D07}"
+
+type PENUMCONNECTIONS = IEnumConnections ()
+type LPENUMCONNECTIONS = IEnumConnections ()
+data CONNECTDATA = TagCONNECTDATA {pUnk :: (IUnknown ()),
+                                   dwCookie :: DWORD}
+                     
+writeCONNECTDATA :: Bool
+                 -> Ptr CONNECTDATA
+                 -> CONNECTDATA
+                 -> IO ()
+writeCONNECTDATA addRefMe__ ptr (TagCONNECTDATA pUnk dwCookie) =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    writeIUnknown addRefMe__ pf1 pUnk
+    let pf2 = addNCastPtr pf1 4
+    writeWord32 pf2 dwCookie
+
+readCONNECTDATA :: Bool
+                -> Ptr CONNECTDATA
+                -> IO CONNECTDATA
+readCONNECTDATA finaliseMe__ ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    pUnk <- readIUnknown finaliseMe__ pf1
+    let pf2 = addNCastPtr pf1 4
+    dwCookie <- readWord32 pf2
+    return (TagCONNECTDATA pUnk dwCookie)
+
+sizeofCONNECTDATA :: Word32
+sizeofCONNECTDATA = 8
+
+type TagCONNECTDATA = CONNECTDATA
+type PCONNECTDATA0 = TagCONNECTDATA
+type TagCONNECTDATA0 = CONNECTDATA
+type LPCONNECTDATA0 = TagCONNECTDATA0
+next :: ULONG
+     -> IEnumConnections a0
+     -> IO [CONNECTDATA]
+next cConnections iptr =
+  enumNext sizeofCONNECTDATA
+           (readCONNECTDATA False)
+           cConnections
+           iptr
+
+skip :: ULONG
+     -> IEnumConnections a0
+     -> IO ()
+skip cConnections iptr =
+  enumSkip cConnections
+           iptr
+
+reset :: IEnumConnections a0
+      -> IO ()
+reset iptr = enumReset iptr
+
+clone :: IEnumConnections a0
+      -> IO (IEnumConnections ())
+clone iptr = enumClone iptr
+
+-- --------------------------------------------------
+-- 
+-- interface IEnumConnectionPoints
+-- 
+-- --------------------------------------------------
+data IEnumConnectionPoints_ a = IEnumConnectionPoints__
+                                  
+type IEnumConnectionPoints a = IUnknown (IEnumConnectionPoints_ a)
+iidIEnumConnectionPoints :: IID (IEnumConnectionPoints ())
+iidIEnumConnectionPoints =
+  mkIID "{B196B285-BAB4-101A-B69C-00AA00341D07}"
+
+type PENUMCONNECTIONPOINTS = IEnumConnectionPoints ()
+type LPENUMCONNECTIONPOINTS = IEnumConnectionPoints ()
+nextECP :: ULONG
+        -> IEnumConnectionPoints a0
+        -> IO [IConnectionPoint a1]
+nextECP cConnections iptr =
+  enumNext sizeofForeignPtr
+           (readIUnknown False)
+           cConnections
+           iptr
+
+skipECP :: ULONG
+        -> IEnumConnectionPoints a0
+        -> IO ()
+skipECP cConnections iptr =
+  enumSkip cConnections
+           iptr
+
+resetECP :: IEnumConnectionPoints a0
+         -> IO ()
+resetECP iptr = enumReset iptr
+
+cloneECP :: IEnumConnectionPoints a0
+         -> IO (IEnumConnectionPoints ())
+cloneECP iptr = enumClone iptr
+
+
+ System/Win32/Com/Automation/SafeArray.hs view
@@ -0,0 +1,316 @@+{-# OPTIONS -#include <windows.h> #-}
+{-# OPTIONS -#include "SafeArrayPrim.h" #-}
+-- Automatically generated by HaskellDirect (ihc.exe), snapshot 171208
+-- Created: 23:37 Pacific Standard Time, Wednesday 17 December, 2008
+-- Command line: -fno-qualified-names -fhs-to-c -fcomlib -fno-export-lists --gen-headers -fout-pointers-are-not-refs --gen-headers -c System/Win32/Com/Automation/SafeArray.idl -o System/Win32/Com/Automation/SafeArray.hs
+
+module System.Win32.Com.Automation.SafeArray where
+
+import Prelude
+import Data.Int (Int32)
+import Data.Word (Word32, Word16)
+import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)
+import Foreign.Ptr (Ptr, FunPtr, castPtr)
+import System.IO.Unsafe (unsafePerformIO)
+import System.Win32.Com (checkHR)
+import System.Win32.Com.Automation.StdTypes (VARTYPE)
+import System.Win32.Com.HDirect.HDirect (nullFinaliser, writefptr, 
+                                         readPtr, sizeofPtr, writeWord32, writeInt32, addNCastPtr, 
+                                         readWord32, readInt32, allocBytes, free, doThenFree, 
+                                         sizeofForeignPtr, marshalllist, trivialFree, freeref, 
+                                         sizeofInt32, marshallref)
+import System.Win32.Com.HDirect.Pointer (makeFO)
+
+{- BEGIN_C_CODE
+#if defined(__MINGW32__) || defined(__CYGWIN32__) || defined(mingw32_BUILD_OS)
+END_C_CODE-}
+{- BEGIN_C_CODE
+#include <w32api.h>
+END_C_CODE-}
+{- BEGIN_C_CODE
+#endif
+END_C_CODE-}
+{- BEGIN_C_CODE
+#if !defined(_MSC_VER) && __W32API_MAJOR_VERSION >= 1
+END_C_CODE-}
+-- --------------------------------------------------
+-- 
+-- interface SAFEARRAY
+-- 
+-- --------------------------------------------------
+newtype SAFEARRAY
+ = SAFEARRAY (ForeignPtr SAFEARRAY)
+ 
+foreign import ccall "&primSafeArrayDestroy" addrOf_SAFEARRAY_primSafeArrayDestroy :: FunPtr (Ptr SAFEARRAY -> IO ())
+marshallSAFEARRAY :: SAFEARRAY
+                  -> IO (ForeignPtr SAFEARRAY)
+marshallSAFEARRAY (SAFEARRAY v) = return (v)
+
+unmarshallSAFEARRAY :: Bool
+                    -> Ptr SAFEARRAY
+                    -> IO SAFEARRAY
+unmarshallSAFEARRAY finaliseMe__ v =
+  do
+    v <- makeFO v (case finaliseMe__ of
+                      False -> nullFinaliser
+                      True -> addrOf_SAFEARRAY_primSafeArrayDestroy)
+    return (SAFEARRAY v)
+
+writeSAFEARRAY :: Ptr (Ptr SAFEARRAY)
+               -> SAFEARRAY
+               -> IO ()
+writeSAFEARRAY ptr (SAFEARRAY v) =
+  writefptr ptr
+            v
+
+readSAFEARRAY :: Bool
+              -> Ptr SAFEARRAY
+              -> IO SAFEARRAY
+readSAFEARRAY finaliseMe__ ptr =
+  do
+    v <- readPtr ptr
+    v <- makeFO v (case finaliseMe__ of
+                      False -> nullFinaliser
+                      True -> addrOf_SAFEARRAY_primSafeArrayDestroy)
+    return (SAFEARRAY v)
+
+sizeofSAFEARRAY :: Word32
+sizeofSAFEARRAY = sizeofPtr
+
+addrToSAFEARRAY :: Ptr a
+                -> SAFEARRAY
+addrToSAFEARRAY v =
+  unsafePerformIO (makeFO (castPtr v) addrOf_SAFEARRAY_primSafeArrayDestroy >>= \ v ->
+                   return (SAFEARRAY v))
+
+data SAFEARRAYBOUND = TagSAFEARRAYBOUND {cElements :: Word32,
+                                         lLbound :: Int32}
+                        
+writeSAFEARRAYBOUND :: Ptr SAFEARRAYBOUND
+                    -> SAFEARRAYBOUND
+                    -> IO ()
+writeSAFEARRAYBOUND ptr (TagSAFEARRAYBOUND cElements lLbound) =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    writeWord32 pf1 cElements
+    let pf2 = addNCastPtr pf1 4
+    writeInt32 pf2 lLbound
+
+readSAFEARRAYBOUND :: Ptr SAFEARRAYBOUND
+                   -> IO SAFEARRAYBOUND
+readSAFEARRAYBOUND ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    cElements <- readWord32 pf1
+    let pf2 = addNCastPtr pf1 4
+    lLbound <- readInt32 pf2
+    return (TagSAFEARRAYBOUND cElements lLbound)
+
+sizeofSAFEARRAYBOUND :: Word32
+sizeofSAFEARRAYBOUND = 8
+
+safeArrayAccessData :: SAFEARRAY
+                    -> IO (Ptr ())
+safeArrayAccessData psa =
+  do
+    ppvData <- allocBytes (fromIntegral sizeofPtr)
+    psa <- marshallSAFEARRAY psa
+    o_safeArrayAccessData <- withForeignPtr psa (\ psa -> prim_System_Win32_Com_Automation_SafeArray_safeArrayAccessData psa ppvData)
+    checkHR o_safeArrayAccessData
+    doThenFree free readPtr ppvData
+
+foreign import stdcall "SafeArrayAccessData" prim_System_Win32_Com_Automation_SafeArray_safeArrayAccessData :: Ptr SAFEARRAY -> Ptr (Ptr ()) -> IO Int32
+safeArrayAllocData :: SAFEARRAY
+                   -> IO ()
+safeArrayAllocData psa =
+  do
+    psa <- marshallSAFEARRAY psa
+    o_safeArrayAllocData <- withForeignPtr psa (\ psa -> prim_System_Win32_Com_Automation_SafeArray_safeArrayAllocData psa)
+    checkHR o_safeArrayAllocData
+
+foreign import stdcall "SafeArrayAllocData" prim_System_Win32_Com_Automation_SafeArray_safeArrayAllocData :: Ptr SAFEARRAY -> IO Int32
+safeArrayAllocDescriptor :: Word32
+                         -> IO SAFEARRAY
+safeArrayAllocDescriptor cDims =
+  do
+    ppsaOut <- allocBytes (fromIntegral sizeofForeignPtr)
+    o_safeArrayAllocDescriptor <- prim_System_Win32_Com_Automation_SafeArray_safeArrayAllocDescriptor cDims ppsaOut
+    checkHR o_safeArrayAllocDescriptor
+    doThenFree free (readSAFEARRAY True) ppsaOut
+
+foreign import stdcall "SafeArrayAllocDescriptor" prim_System_Win32_Com_Automation_SafeArray_safeArrayAllocDescriptor :: Word32 -> Ptr (Ptr SAFEARRAY) -> IO Int32
+safeArrayCopy :: SAFEARRAY
+              -> IO SAFEARRAY
+safeArrayCopy psa =
+  do
+    ppsaOut <- allocBytes (fromIntegral sizeofForeignPtr)
+    psa <- marshallSAFEARRAY psa
+    o_safeArrayCopy <- withForeignPtr psa (\ psa -> prim_System_Win32_Com_Automation_SafeArray_safeArrayCopy psa ppsaOut)
+    checkHR o_safeArrayCopy
+    doThenFree free (readSAFEARRAY True) ppsaOut
+
+foreign import stdcall "SafeArrayCopy" prim_System_Win32_Com_Automation_SafeArray_safeArrayCopy :: Ptr SAFEARRAY -> Ptr (Ptr SAFEARRAY) -> IO Int32
+safeArrayCreate :: VARTYPE
+                -> [SAFEARRAYBOUND]
+                -> IO SAFEARRAY
+safeArrayCreate vt rgsabound =
+  let
+   cDims = (fromIntegral (length rgsabound) :: Word32)
+  in
+  do
+    rgsabound <- marshalllist sizeofSAFEARRAYBOUND writeSAFEARRAYBOUND rgsabound
+    o_safeArrayCreate <- prim_System_Win32_Com_Automation_SafeArray_safeArrayCreate vt cDims rgsabound
+    freeref trivialFree rgsabound
+    unmarshallSAFEARRAY True o_safeArrayCreate
+
+foreign import stdcall "SafeArrayCreate" prim_System_Win32_Com_Automation_SafeArray_safeArrayCreate :: Word16 -> Word32 -> Ptr SAFEARRAYBOUND -> IO (Ptr SAFEARRAY)
+safeArrayDestroy :: SAFEARRAY
+                 -> IO ()
+safeArrayDestroy psa =
+  do
+    psa <- marshallSAFEARRAY psa
+    o_safeArrayDestroy <- withForeignPtr psa (\ psa -> prim_System_Win32_Com_Automation_SafeArray_safeArrayDestroy psa)
+    checkHR o_safeArrayDestroy
+
+foreign import stdcall "SafeArrayDestroy" prim_System_Win32_Com_Automation_SafeArray_safeArrayDestroy :: Ptr SAFEARRAY -> IO Int32
+safeArrayDestroyData :: SAFEARRAY
+                     -> IO ()
+safeArrayDestroyData psa =
+  do
+    psa <- marshallSAFEARRAY psa
+    o_safeArrayDestroyData <- withForeignPtr psa (\ psa -> prim_System_Win32_Com_Automation_SafeArray_safeArrayDestroyData psa)
+    checkHR o_safeArrayDestroyData
+
+foreign import stdcall "SafeArrayDestroyData" prim_System_Win32_Com_Automation_SafeArray_safeArrayDestroyData :: Ptr SAFEARRAY -> IO Int32
+safeArrayDestroyDescriptor :: SAFEARRAY
+                           -> IO ()
+safeArrayDestroyDescriptor psa =
+  do
+    psa <- marshallSAFEARRAY psa
+    o_safeArrayDestroyDescriptor <- withForeignPtr psa (\ psa -> prim_System_Win32_Com_Automation_SafeArray_safeArrayDestroyDescriptor psa)
+    checkHR o_safeArrayDestroyDescriptor
+
+foreign import stdcall "SafeArrayDestroyDescriptor" prim_System_Win32_Com_Automation_SafeArray_safeArrayDestroyDescriptor :: Ptr SAFEARRAY -> IO Int32
+safeArrayGetDim :: SAFEARRAY
+                -> IO Word32
+safeArrayGetDim psa =
+  do
+    psa <- marshallSAFEARRAY psa
+    withForeignPtr psa (\ psa -> prim_System_Win32_Com_Automation_SafeArray_safeArrayGetDim psa)
+
+foreign import stdcall "SafeArrayGetDim" prim_System_Win32_Com_Automation_SafeArray_safeArrayGetDim :: Ptr SAFEARRAY -> IO Word32
+safeArrayGetElement :: SAFEARRAY
+                    -> Ptr Int32
+                    -> Ptr ()
+                    -> IO ()
+safeArrayGetElement psa rgIndices pv =
+  do
+    psa <- marshallSAFEARRAY psa
+    o_safeArrayGetElement <- withForeignPtr psa (\ psa -> prim_System_Win32_Com_Automation_SafeArray_safeArrayGetElement psa rgIndices pv)
+    checkHR o_safeArrayGetElement
+
+foreign import stdcall "SafeArrayGetElement" prim_System_Win32_Com_Automation_SafeArray_safeArrayGetElement :: Ptr SAFEARRAY -> Ptr Int32 -> Ptr () -> IO Int32
+safeArrayGetElemsize :: SAFEARRAY
+                     -> IO Word32
+safeArrayGetElemsize psa =
+  do
+    psa <- marshallSAFEARRAY psa
+    withForeignPtr psa (\ psa -> prim_System_Win32_Com_Automation_SafeArray_safeArrayGetElemsize psa)
+
+foreign import stdcall "SafeArrayGetElemsize" prim_System_Win32_Com_Automation_SafeArray_safeArrayGetElemsize :: Ptr SAFEARRAY -> IO Word32
+safeArrayGetLBound :: SAFEARRAY
+                   -> Word32
+                   -> IO Int32
+safeArrayGetLBound psa nDim =
+  do
+    plLbound <- allocBytes (fromIntegral sizeofInt32)
+    psa <- marshallSAFEARRAY psa
+    o_safeArrayGetLBound <- withForeignPtr psa (\ psa -> prim_System_Win32_Com_Automation_SafeArray_safeArrayGetLBound psa nDim plLbound)
+    checkHR o_safeArrayGetLBound
+    doThenFree free readInt32 plLbound
+
+foreign import stdcall "SafeArrayGetLBound" prim_System_Win32_Com_Automation_SafeArray_safeArrayGetLBound :: Ptr SAFEARRAY -> Word32 -> Ptr Int32 -> IO Int32
+safeArrayGetUBound :: SAFEARRAY
+                   -> Word32
+                   -> IO Int32
+safeArrayGetUBound psa nDim =
+  do
+    plLbound <- allocBytes (fromIntegral sizeofInt32)
+    psa <- marshallSAFEARRAY psa
+    o_safeArrayGetUBound <- withForeignPtr psa (\ psa -> prim_System_Win32_Com_Automation_SafeArray_safeArrayGetUBound psa nDim plLbound)
+    checkHR o_safeArrayGetUBound
+    doThenFree free readInt32 plLbound
+
+foreign import stdcall "SafeArrayGetUBound" prim_System_Win32_Com_Automation_SafeArray_safeArrayGetUBound :: Ptr SAFEARRAY -> Word32 -> Ptr Int32 -> IO Int32
+safeArrayLock :: SAFEARRAY
+              -> IO ()
+safeArrayLock psa =
+  do
+    psa <- marshallSAFEARRAY psa
+    o_safeArrayLock <- withForeignPtr psa (\ psa -> prim_System_Win32_Com_Automation_SafeArray_safeArrayLock psa)
+    checkHR o_safeArrayLock
+
+foreign import stdcall "SafeArrayLock" prim_System_Win32_Com_Automation_SafeArray_safeArrayLock :: Ptr SAFEARRAY -> IO Int32
+safeArrayPtrOfIndex :: SAFEARRAY
+                    -> Ptr Int32
+                    -> IO (Ptr ())
+safeArrayPtrOfIndex psa rgIndices =
+  do
+    ppvData <- allocBytes (fromIntegral sizeofPtr)
+    psa <- marshallSAFEARRAY psa
+    o_safeArrayPtrOfIndex <- withForeignPtr psa (\ psa -> prim_System_Win32_Com_Automation_SafeArray_safeArrayPtrOfIndex psa rgIndices ppvData)
+    checkHR o_safeArrayPtrOfIndex
+    doThenFree free readPtr ppvData
+
+foreign import stdcall "SafeArrayPtrOfIndex" prim_System_Win32_Com_Automation_SafeArray_safeArrayPtrOfIndex :: Ptr SAFEARRAY -> Ptr Int32 -> Ptr (Ptr ()) -> IO Int32
+safeArrayPutElement :: SAFEARRAY
+                    -> Ptr Int32
+                    -> Ptr ()
+                    -> IO ()
+safeArrayPutElement psa rgIndices pv =
+  do
+    psa <- marshallSAFEARRAY psa
+    o_safeArrayPutElement <- withForeignPtr psa (\ psa -> prim_System_Win32_Com_Automation_SafeArray_safeArrayPutElement psa rgIndices pv)
+    checkHR o_safeArrayPutElement
+
+foreign import stdcall "SafeArrayPutElement" prim_System_Win32_Com_Automation_SafeArray_safeArrayPutElement :: Ptr SAFEARRAY -> Ptr Int32 -> Ptr () -> IO Int32
+safeArrayRedim :: SAFEARRAY
+               -> SAFEARRAYBOUND
+               -> IO ()
+safeArrayRedim psa psaboundNew =
+  do
+    psa <- marshallSAFEARRAY psa
+    psaboundNew <- marshallref (allocBytes (fromIntegral sizeofSAFEARRAYBOUND)) writeSAFEARRAYBOUND psaboundNew
+    o_safeArrayRedim <- withForeignPtr psa (\ psa -> prim_System_Win32_Com_Automation_SafeArray_safeArrayRedim psa psaboundNew)
+    free psaboundNew
+    checkHR o_safeArrayRedim
+
+foreign import stdcall "SafeArrayRedim" prim_System_Win32_Com_Automation_SafeArray_safeArrayRedim :: Ptr SAFEARRAY -> Ptr SAFEARRAYBOUND -> IO Int32
+safeArrayUnaccessData :: SAFEARRAY
+                      -> IO ()
+safeArrayUnaccessData psa =
+  do
+    psa <- marshallSAFEARRAY psa
+    o_safeArrayUnaccessData <- withForeignPtr psa (\ psa -> prim_System_Win32_Com_Automation_SafeArray_safeArrayUnaccessData psa)
+    checkHR o_safeArrayUnaccessData
+
+foreign import stdcall "SafeArrayUnaccessData" prim_System_Win32_Com_Automation_SafeArray_safeArrayUnaccessData :: Ptr SAFEARRAY -> IO Int32
+safeArrayUnlock :: SAFEARRAY
+                -> IO ()
+safeArrayUnlock psa =
+  do
+    psa <- marshallSAFEARRAY psa
+    o_safeArrayUnlock <- withForeignPtr psa (\ psa -> prim_System_Win32_Com_Automation_SafeArray_safeArrayUnlock psa)
+    checkHR o_safeArrayUnlock
+
+foreign import stdcall "SafeArrayUnlock" prim_System_Win32_Com_Automation_SafeArray_safeArrayUnlock :: Ptr SAFEARRAY -> IO Int32
+{- BEGIN_C_CODE
+#endif
+END_C_CODE-}
+
+ System/Win32/Com/Automation/StdTypes.hs view
@@ -0,0 +1,237 @@+-- Automatically generated by HaskellDirect (ihc.exe), snapshot 171208
+-- Created: 23:37 Pacific Standard Time, Wednesday 17 December, 2008
+-- Command line: -fno-qualified-names -fno-export-list -fno-gen-variant-instances -fout-pointers-are-not-refs --gen-headers -c System/Win32/Com/Automation/StdTypes.idl -o System/Win32/Com/Automation/StdTypes.hs
+
+module System.Win32.Com.Automation.StdTypes where
+
+import Prelude
+import Data.Int (Int32, Int16)
+import Data.Word (Word32, Word16)
+import Foreign.Ptr (Ptr)
+import System.Win32.Com (IID, CLSID, GUID)
+import System.Win32.Com.HDirect.HDirect (Wchar_t)
+import System.Win32.Com.HDirect.WideString (WideString)
+
+{- BEGIN_C_CODE
+#ifdef __MINGW32__
+END_C_CODE-}
+{- BEGIN_C_CODE
+#define __need_wchar_t
+END_C_CODE-}
+{- BEGIN_C_CODE
+#include <stddef.h>
+END_C_CODE-}
+{- BEGIN_C_CODE
+#endif
+END_C_CODE-}
+type UINT = Word32
+type INT = Int32
+type BOOL = Int32
+type BYTE = Char
+type LONG = Int32
+type ULONG = Word32
+type WORD = Word16
+type DWORD = Word32
+type VARTYPE = Word16
+type USHORT = Word16
+type LCID = DWORD
+type SCODE = LONG
+type SHORT = Int16
+type WCHAR = Wchar_t
+type TCHAR = WCHAR
+type OLECHAR = WCHAR
+type LPOLESTR = WideString
+type LPCOLESTR = WideString
+type PVOID = Ptr ()
+type LPVOID = Ptr ()
+type FLOAT = Float
+{- BEGIN_C_CODE
+typedef struct _GUID {
+END_C_CODE-}
+{- BEGIN_C_CODE
+DWORD Data1;
+END_C_CODE-}
+{- BEGIN_C_CODE
+WORD  Data2;
+END_C_CODE-}
+{- BEGIN_C_CODE
+WORD  Data3;
+END_C_CODE-}
+{- BEGIN_C_CODE
+BYTE  Data4[8];
+END_C_CODE-}
+{- BEGIN_C_CODE
+} GUID;
+END_C_CODE-}
+{- BEGIN_C_CODE
+typedef GUID IID;
+END_C_CODE-}
+type LPIID = IID ()
+{- BEGIN_C_CODE
+typedef GUID CLSID;
+END_C_CODE-}
+type LPCLSID = CLSID
+type FMTID = GUID
+type LPFMTID = GUID
+type HWND = Ptr ()
+type HMENU = Ptr ()
+type HANDLE = Ptr ()
+type REFGUID = GUID
+type REFIID = IID ()
+type REFCLSID = CLSID
+type REFFMTID = GUID
+data VARENUM
+ = VT_EMPTY
+ | VT_NULL
+ | VT_I2
+ | VT_I4
+ | VT_R4
+ | VT_R8
+ | VT_CY
+ | VT_DATE
+ | VT_BSTR
+ | VT_DISPATCH
+ | VT_ERROR
+ | VT_BOOL
+ | VT_VARIANT
+ | VT_UNKNOWN
+ | VT_DECIMAL
+ | VT_I1
+ | VT_UI1
+ | VT_UI2
+ | VT_UI4
+ | VT_I8
+ | VT_UI8
+ | VT_INT
+ | VT_UINT
+ | VT_VOID
+ | VT_HRESULT
+ | VT_PTR
+ | VT_SAFEARRAY
+ | VT_CARRAY
+ | VT_USERDEFINED
+ | VT_LPSTR
+ | VT_LPWSTR
+ | VT_FILETIME
+ | VT_BLOB
+ | VT_STREAM
+ | VT_STORAGE
+ | VT_STREAMED_OBJECT
+ | VT_STORED_OBJECT
+ | VT_BLOB_OBJECT
+ | VT_CF
+ | VT_CLSID
+ | VT_BSTR_BLOB
+ | VT_ILLEGALMASKED
+ | VT_TYPEMASK
+ | VT_VECTOR
+ | VT_ARRAY
+ | VT_BYREF
+ | VT_RESERVED
+ | VT_ILLEGAL
+ 
+instance Enum (VARENUM) where
+  fromEnum v =
+    case v of
+       VT_EMPTY -> 0
+       VT_NULL -> 1
+       VT_I2 -> 2
+       VT_I4 -> 3
+       VT_R4 -> 4
+       VT_R8 -> 5
+       VT_CY -> 6
+       VT_DATE -> 7
+       VT_BSTR -> 8
+       VT_DISPATCH -> 9
+       VT_ERROR -> 10
+       VT_BOOL -> 11
+       VT_VARIANT -> 12
+       VT_UNKNOWN -> 13
+       VT_DECIMAL -> 14
+       VT_I1 -> 16
+       VT_UI1 -> 17
+       VT_UI2 -> 18
+       VT_UI4 -> 19
+       VT_I8 -> 20
+       VT_UI8 -> 21
+       VT_INT -> 22
+       VT_UINT -> 23
+       VT_VOID -> 24
+       VT_HRESULT -> 25
+       VT_PTR -> 26
+       VT_SAFEARRAY -> 27
+       VT_CARRAY -> 28
+       VT_USERDEFINED -> 29
+       VT_LPSTR -> 30
+       VT_LPWSTR -> 31
+       VT_FILETIME -> 64
+       VT_BLOB -> 65
+       VT_STREAM -> 66
+       VT_STORAGE -> 67
+       VT_STREAMED_OBJECT -> 68
+       VT_STORED_OBJECT -> 69
+       VT_BLOB_OBJECT -> 70
+       VT_CF -> 71
+       VT_CLSID -> 72
+       VT_BSTR_BLOB -> 4095
+       VT_ILLEGALMASKED -> 4095
+       VT_TYPEMASK -> 4095
+       VT_VECTOR -> 4096
+       VT_ARRAY -> 8192
+       VT_BYREF -> 16384
+       VT_RESERVED -> 32768
+       VT_ILLEGAL -> 65535
+  
+  toEnum v =
+    case v of
+       0 -> VT_EMPTY
+       1 -> VT_NULL
+       2 -> VT_I2
+       3 -> VT_I4
+       4 -> VT_R4
+       5 -> VT_R8
+       6 -> VT_CY
+       7 -> VT_DATE
+       8 -> VT_BSTR
+       9 -> VT_DISPATCH
+       10 -> VT_ERROR
+       11 -> VT_BOOL
+       12 -> VT_VARIANT
+       13 -> VT_UNKNOWN
+       14 -> VT_DECIMAL
+       16 -> VT_I1
+       17 -> VT_UI1
+       18 -> VT_UI2
+       19 -> VT_UI4
+       20 -> VT_I8
+       21 -> VT_UI8
+       22 -> VT_INT
+       23 -> VT_UINT
+       24 -> VT_VOID
+       25 -> VT_HRESULT
+       26 -> VT_PTR
+       27 -> VT_SAFEARRAY
+       28 -> VT_CARRAY
+       29 -> VT_USERDEFINED
+       30 -> VT_LPSTR
+       31 -> VT_LPWSTR
+       64 -> VT_FILETIME
+       65 -> VT_BLOB
+       66 -> VT_STREAM
+       67 -> VT_STORAGE
+       68 -> VT_STREAMED_OBJECT
+       69 -> VT_STORED_OBJECT
+       70 -> VT_BLOB_OBJECT
+       71 -> VT_CF
+       72 -> VT_CLSID
+       4095 -> VT_BSTR_BLOB
+       4095 -> VT_ILLEGALMASKED
+       4095 -> VT_TYPEMASK
+       4096 -> VT_VECTOR
+       8192 -> VT_ARRAY
+       16384 -> VT_BYREF
+       32768 -> VT_RESERVED
+       65535 -> VT_ILLEGAL
+       _ -> error "unmarshallVARENUM: illegal enum value "
+  
+
+ System/Win32/Com/Automation/TypeLib.hs view
@@ -0,0 +1,2877 @@+-- Automatically generated by HaskellDirect (ihc.exe), snapshot 171208
+-- Created: 23:37 Pacific Standard Time, Wednesday 17 December, 2008
+-- Command line: -fno-qualified-names -fno-export-list -fappend-interface-short-name -fno-overload-variant --gen-headers -c System/Win32/Com/Automation/TypeLib.idl -o System/Win32/Com/Automation/TypeLib.hs
+
+module System.Win32.Com.Automation.TypeLib where
+
+import Prelude
+import Data.Bits ((.&.))
+import Data.Int (Int32, Int16)
+import Data.Maybe (mapMaybe)
+import Data.Word (Word32, Word16)
+import Foreign.ForeignPtr (withForeignPtr)
+import Foreign.Ptr (Ptr, castPtr)
+import System.Win32.Com (GUID, writeGUID, readGUID, freeBSTR, 
+                         writeBSTR, readBSTR, IUnknown, writeIUnknown, readIUnknown, IID, 
+                         mkIID, marshallGUID, invokeAndCheck, marshallIUnknown, 
+                         marshallBSTR, marshallIID, invokeIt)
+import System.Win32.Com.Automation (VARIANT, copyVARIANT, 
+                                    unmarshallVARIANT, writeVARIANT, sizeofVARIANT, readVARIANT, 
+                                    marshallVARIANT, allocVARIANT)
+import System.Win32.Com.Automation.StdTypes (LONG, ULONG, DWORD, 
+                                             VARTYPE, USHORT, WORD, LPOLESTR, LCID, SCODE, SHORT, 
+                                             PVOID, REFGUID, UINT, INT, BOOL)
+import System.Win32.Com.HDirect.HDirect (writeWord32, writeInt32, 
+                                         addNCastPtr, readWord32, readInt32, marshallUnion, 
+                                         unmarshallUnion, allocBytes, writeunique, readunique, 
+                                         writeWord16, readWord16, free, writelist, 
+                                         unmarshallWord16, unmarshalllist, trivialFree, 
+                                         writeEnum32, readEnum32, derefPtr, marshalllist, 
+                                         sizeofInt32, writePtr, readPtr, unmarshallWord32, 
+                                         Flags(..), pow2Series, orList, writeInt16, readInt16, 
+                                         unmarshallInt16, writeMaybe, readMaybe, sizeofWord32, 
+                                         doThenFree, marshallref, sizeofPtr, marshallEnum32, 
+                                         sizeofForeignPtr, freeref, sizeofWord16)
+import System.Win32.Com.HDirect.WideString (writeWideString, 
+                                            readWideString, marshallWideString, freeWideString, 
+                                            WideString, unmarshallWideString)
+
+{-
+#if defined(FOR_GHC)
+#define BEGIN_GHC_ONLY -}
+#define END_GHC_ONLY   {-
+#define BEGIN_NOT_FOR_GHC {-
+#define END_NOT_FOR_GHC -}
+#define ELSE_FOR_GHC -}-}
+#endif
+-}
+
+
+{- BEGIN_C_CODE
+#include "StdTypes.h"
+END_C_CODE-}
+{- BEGIN_C_CODE
+typedef void* VARIANT;
+END_C_CODE-}
+{- BEGIN_C_CODE
+typedef void* BSTR;
+END_C_CODE-}
+{- BEGIN_C_CODE
+typedef DWORD HRESULT;
+END_C_CODE-}
+{- BEGIN_C_CODE
+typedef void* IUnknown;
+END_C_CODE-}
+data SAFEARRAYBOUND = TagSAFEARRAYBOUND {cElements :: ULONG,
+                                         lLbound :: LONG}
+                        
+writeSAFEARRAYBOUND :: Ptr SAFEARRAYBOUND
+                    -> SAFEARRAYBOUND
+                    -> IO ()
+writeSAFEARRAYBOUND ptr (TagSAFEARRAYBOUND cElements lLbound) =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    writeWord32 pf1 cElements
+    let pf2 = addNCastPtr pf1 4
+    writeInt32 pf2 lLbound
+
+readSAFEARRAYBOUND :: Ptr SAFEARRAYBOUND
+                   -> IO SAFEARRAYBOUND
+readSAFEARRAYBOUND ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    cElements <- readWord32 pf1
+    let pf2 = addNCastPtr pf1 4
+    lLbound <- readInt32 pf2
+    return (TagSAFEARRAYBOUND cElements lLbound)
+
+sizeofSAFEARRAYBOUND :: Word32
+sizeofSAFEARRAYBOUND = 8
+
+type LPSAFEARRAYBOUND = SAFEARRAYBOUND
+type DISPID = LONG
+type MEMBERID = DISPID
+type HREFTYPE = DWORD
+data TYPEKIND
+ = TKIND_ENUM
+ | TKIND_RECORD
+ | TKIND_MODULE
+ | TKIND_INTERFACE
+ | TKIND_DISPATCH
+ | TKIND_COCLASS
+ | TKIND_ALIAS
+ | TKIND_UNION
+ | TKIND_MAX
+ deriving (Enum)
+type IHC_TAG_4 = TYPEDESC
+type IHC_TAG_5 = ARRAYDESC
+data IHC_TAG_3
+ = Lptdesc (Maybe IHC_TAG_4)
+ | Lpadesc (Maybe IHC_TAG_5)
+ | Hreftype HREFTYPE
+ | IHC_TAG_3_Anon
+ 
+marshallIHC_TAG_3 :: IHC_TAG_3
+                  -> IO (IHC_TAG_3, Word16)
+marshallIHC_TAG_3 = marshallUnion "marshallIHC_TAG_3"
+
+unmarshallIHC_TAG_3 :: IHC_TAG_3
+                    -> Word16
+                    -> IO IHC_TAG_3
+unmarshallIHC_TAG_3 = unmarshallUnion "unmarshallIHC_TAG_3"
+
+writeIHC_TAG_3 :: (Word16 -> IO ())
+               -> Ptr IHC_TAG_3
+               -> IHC_TAG_3
+               -> IO ()
+writeIHC_TAG_3 write_tag ptr v =
+  case v of
+     (Lptdesc lptdesc) -> do
+                            write_tag 26
+                            writeunique (allocBytes (fromIntegral sizeofTYPEDESC)) writeTYPEDESC (castPtr ptr) lptdesc
+     (Lpadesc lpadesc) -> do
+                            write_tag 28
+                            writeunique (allocBytes (fromIntegral sizeofARRAYDESC)) writeARRAYDESC (castPtr ptr) lpadesc
+     (Hreftype hreftype) -> do
+                              write_tag 29
+                              writeWord32 (castPtr ptr) hreftype
+     IHC_TAG_3_Anon -> return ()
+
+readIHC_TAG_3 :: IO Word16
+              -> Ptr IHC_TAG_3
+              -> IO IHC_TAG_3
+readIHC_TAG_3 read_tag ptr =
+  do
+    tag <- read_tag
+    case tag of
+       26 -> do
+               v <- readunique readTYPEDESC (castPtr ptr)
+               return (Lptdesc v)
+       27 -> do
+               v <- readunique readTYPEDESC (castPtr ptr)
+               return (Lptdesc v)
+       28 -> do
+               v <- readunique readARRAYDESC (castPtr ptr)
+               return (Lpadesc v)
+       29 -> do
+               v <- readWord32 (castPtr ptr)
+               return (Hreftype v)
+       _ -> return (IHC_TAG_3_Anon)
+
+sizeofIHC_TAG_3 :: Word32
+sizeofIHC_TAG_3 = 4
+
+freeIHC_TAG_3 :: Word16
+              -> Ptr IHC_TAG_3
+              -> IO ()
+freeIHC_TAG_3 read_tag ptr =
+  do
+    tag <- return (read_tag)
+    case tag of
+       26 -> return ()
+       27 -> return ()
+       28 -> return ()
+       29 -> return ()
+       _ -> return ()
+
+type IHC_TAG_2 = IHC_TAG_3
+data TYPEDESC = TagTYPEDESC {iHC_TAG_1 :: IHC_TAG_3,
+                             vt :: VARTYPE}
+                  
+writeTYPEDESC :: Ptr TYPEDESC
+              -> TYPEDESC
+              -> IO ()
+writeTYPEDESC ptr (TagTYPEDESC iHC_TAG_1 vt) =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    writeIHC_TAG_3 (writeWord16 (addNCastPtr pf0 4)) pf1 iHC_TAG_1
+    let pf2 = addNCastPtr pf1 4
+    writeWord16 pf2 vt
+
+readTYPEDESC :: Ptr TYPEDESC
+             -> IO TYPEDESC
+readTYPEDESC ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    iHC_TAG_1 <- readIHC_TAG_3 (readWord16 (addNCastPtr pf0 4)) pf1
+    let pf2 = addNCastPtr pf1 4
+    vt <- readWord16 pf2
+    return (TagTYPEDESC iHC_TAG_1 vt)
+
+sizeofTYPEDESC :: Word32
+sizeofTYPEDESC = 8
+
+data ARRAYDESC = TagARRAYDESC {tdescElem :: TYPEDESC,
+                               rgbounds :: [SAFEARRAYBOUND]}
+                   
+freeARRAYDESC :: Ptr ARRAYDESC
+              -> IO ()
+freeARRAYDESC ptr =
+  let
+   struct_ptr__ = addNCastPtr ptr 12
+  in
+  free struct_ptr__
+
+writeARRAYDESC :: Ptr ARRAYDESC
+               -> ARRAYDESC
+               -> IO ()
+writeARRAYDESC ptr (TagARRAYDESC tdescElem rgbounds) =
+  let
+   cDims = (fromIntegral (length rgbounds) :: Word16)
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    writeTYPEDESC pf1 tdescElem
+    let pf2 = addNCastPtr pf1 8
+    writeWord16 pf2 cDims
+    let pf3 = addNCastPtr pf2 4
+    writelist False sizeofSAFEARRAYBOUND writeSAFEARRAYBOUND pf3 rgbounds
+
+readARRAYDESC :: Ptr ARRAYDESC
+              -> IO ARRAYDESC
+readARRAYDESC ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    tdescElem <- readTYPEDESC pf1
+    let pf2 = addNCastPtr pf1 8
+    cDims <- readWord16 pf2
+    let pf3 = addNCastPtr pf2 4
+    rgbounds <- return pf3
+    cDims <- unmarshallWord16 cDims
+    rgbounds <- unmarshalllist sizeofSAFEARRAYBOUND 0 ((fromIntegral cDims :: Word32)) readSAFEARRAYBOUND rgbounds
+    return (TagARRAYDESC tdescElem rgbounds)
+
+sizeofARRAYDESC :: Word32
+sizeofARRAYDESC = 20
+
+type VARIANTARG = VARIANT
+data PARAMDESCEX = TagPARAMDESCEX {cBytes :: ULONG,
+                                   varDefaultValue :: VARIANT}
+                     
+freePARAMDESCEX :: Ptr PARAMDESCEX
+                -> IO ()
+freePARAMDESCEX ptr =
+  let
+   struct_ptr__ = addNCastPtr ptr 8
+  in
+  trivialFree struct_ptr__
+
+writePARAMDESCEX :: Ptr PARAMDESCEX
+                 -> PARAMDESCEX
+                 -> IO ()
+writePARAMDESCEX ptr (TagPARAMDESCEX cBytes varDefaultValue) =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    writeWord32 pf1 cBytes
+    let pf2 = addNCastPtr pf1 8
+    copyVARIANT pf2 varDefaultValue
+
+readPARAMDESCEX :: Ptr PARAMDESCEX
+                -> IO PARAMDESCEX
+readPARAMDESCEX ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    cBytes <- readWord32 pf1
+    let pf2 = addNCastPtr pf1 8
+    varDefaultValue <- unmarshallVARIANT pf2
+    return (TagPARAMDESCEX cBytes varDefaultValue)
+
+sizeofPARAMDESCEX :: Word32
+sizeofPARAMDESCEX = 24
+
+type LPPARAMDESCEX = Maybe PARAMDESCEX
+data PARAMDESC = TagPARAMDESC {pparamdescex :: LPPARAMDESCEX,
+                               wParamFlags :: USHORT}
+                   
+freePARAMDESC :: Ptr PARAMDESC
+              -> IO ()
+freePARAMDESC ptr =
+  let
+   struct_ptr__ = addNCastPtr ptr 0
+  in
+  trivialFree struct_ptr__
+
+writePARAMDESC :: Ptr PARAMDESC
+               -> PARAMDESC
+               -> IO ()
+writePARAMDESC ptr (TagPARAMDESC pparamdescex wParamFlags) =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    writeunique (allocBytes (fromIntegral sizeofPARAMDESCEX)) writePARAMDESCEX pf1 pparamdescex
+    let pf2 = addNCastPtr pf1 4
+    writeWord16 pf2 wParamFlags
+
+readPARAMDESC :: Ptr PARAMDESC
+              -> IO PARAMDESC
+readPARAMDESC ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    pparamdescex <- readunique readPARAMDESCEX pf1
+    let pf2 = addNCastPtr pf1 4
+    wParamFlags <- readWord16 pf2
+    return (TagPARAMDESC pparamdescex wParamFlags)
+
+sizeofPARAMDESC :: Word32
+sizeofPARAMDESC = 8
+
+type LPPARAMDESC = PARAMDESC
+pARAMFLAG_NONE :: USHORT
+pARAMFLAG_NONE = 0x0
+
+pARAMFLAG_FIN :: USHORT
+pARAMFLAG_FIN = 0x1
+
+pARAMFLAG_FOUT :: USHORT
+pARAMFLAG_FOUT = 0x2
+
+pARAMFLAG_FLCID :: USHORT
+pARAMFLAG_FLCID = 0x4
+
+pARAMFLAG_FRETVAL :: USHORT
+pARAMFLAG_FRETVAL = 0x8
+
+pARAMFLAG_FOPT :: USHORT
+pARAMFLAG_FOPT = 0x10
+
+pARAMFLAG_FHASDEFAULT :: USHORT
+pARAMFLAG_FHASDEFAULT = 0x20
+
+data IDLDESC = TagIDLDESC {dwReserved :: ULONG,
+                           wIDLFlags :: USHORT}
+                 
+writeIDLDESC :: Ptr IDLDESC
+             -> IDLDESC
+             -> IO ()
+writeIDLDESC ptr (TagIDLDESC dwReserved wIDLFlags) =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    writeWord32 pf1 dwReserved
+    let pf2 = addNCastPtr pf1 4
+    writeWord16 pf2 wIDLFlags
+
+readIDLDESC :: Ptr IDLDESC
+            -> IO IDLDESC
+readIDLDESC ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    dwReserved <- readWord32 pf1
+    let pf2 = addNCastPtr pf1 4
+    wIDLFlags <- readWord16 pf2
+    return (TagIDLDESC dwReserved wIDLFlags)
+
+sizeofIDLDESC :: Word32
+sizeofIDLDESC = 8
+
+type LPIDLDESC = IDLDESC
+iDLFLAG_NONE :: USHORT
+iDLFLAG_NONE = 0
+
+iDLFLAG_FIN :: USHORT
+iDLFLAG_FIN = 1
+
+iDLFLAG_FOUT :: USHORT
+iDLFLAG_FOUT = 2
+
+iDLFLAG_FLCID :: USHORT
+iDLFLAG_FLCID = 4
+
+iDLFLAG_FRETVAL :: USHORT
+iDLFLAG_FRETVAL = 8
+
+{- BEGIN_C_CODE
+#if 1
+END_C_CODE-}
+{- BEGIN_C_CODE
+/* the following is what MIDL knows how to remote */
+END_C_CODE-}
+data ELEMDESC = TagELEMDESC {tdesc :: TYPEDESC,
+                             paramdesc :: PARAMDESC}
+                  
+freeELEMDESC :: Ptr ELEMDESC
+             -> IO ()
+freeELEMDESC ptr =
+  let
+   struct_ptr__ = addNCastPtr ptr 8
+  in
+  freePARAMDESC struct_ptr__
+
+writeELEMDESC :: Ptr ELEMDESC
+              -> ELEMDESC
+              -> IO ()
+writeELEMDESC ptr (TagELEMDESC tdesc paramdesc) =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    writeTYPEDESC pf1 tdesc
+    let pf2 = addNCastPtr pf1 8
+    writePARAMDESC pf2 paramdesc
+
+readELEMDESC :: Ptr ELEMDESC
+             -> IO ELEMDESC
+readELEMDESC ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    tdesc <- readTYPEDESC pf1
+    let pf2 = addNCastPtr pf1 8
+    paramdesc <- readPARAMDESC pf2
+    return (TagELEMDESC tdesc paramdesc)
+
+sizeofELEMDESC :: Word32
+sizeofELEMDESC = 16
+
+{- BEGIN_C_CODE
+#else /* 0 */
+END_C_CODE-}
+{- BEGIN_C_CODE
+typedef struct tagELEMDESC {
+END_C_CODE-}
+{- BEGIN_C_CODE
+    TYPEDESC tdesc;             /* the type of the element */
+END_C_CODE-}
+{- BEGIN_C_CODE
+    union {
+END_C_CODE-}
+{- BEGIN_C_CODE
+        IDLDESC idldesc;        /* info for remoting the element */
+END_C_CODE-}
+{- BEGIN_C_CODE
+        PARAMDESC paramdesc;    /* info about the parameter */
+END_C_CODE-}
+{- BEGIN_C_CODE
+    };
+END_C_CODE-}
+{- BEGIN_C_CODE
+} ELEMDESC, * LPELEMDESC;
+END_C_CODE-}
+{- BEGIN_C_CODE
+#endif /* 0 */
+END_C_CODE-}
+data TYPEATTR = TagTYPEATTR {guid :: GUID,
+                             lcid :: LCID,
+                             dwReserved0 :: DWORD,
+                             memidConstructor :: MEMBERID,
+                             memidDestructor :: MEMBERID,
+                             lpstrSchema :: LPOLESTR,
+                             cbSizeInstance :: ULONG,
+                             typekind :: TYPEKIND,
+                             cFuncs :: WORD,
+                             cVars :: WORD,
+                             cImplTypes :: WORD,
+                             cbSizeVft :: WORD,
+                             cbAlignment :: WORD,
+                             wTypeFlags :: WORD,
+                             wMajorVerNum :: WORD,
+                             wMinorVerNum :: WORD,
+                             tdescAlias :: TYPEDESC,
+                             idldescType :: IDLDESC}
+                  
+writeTYPEATTR :: Ptr TYPEATTR
+              -> TYPEATTR
+              -> IO ()
+writeTYPEATTR ptr (TagTYPEATTR guid lcid dwReserved0 memidConstructor memidDestructor lpstrSchema cbSizeInstance typekind cFuncs cVars cImplTypes cbSizeVft cbAlignment wTypeFlags wMajorVerNum wMinorVerNum tdescAlias idldescType) =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    writeGUID pf1 guid
+    let pf2 = addNCastPtr pf1 16
+    writeWord32 pf2 lcid
+    let pf3 = addNCastPtr pf2 4
+    writeWord32 pf3 dwReserved0
+    let pf4 = addNCastPtr pf3 4
+    writeInt32 pf4 memidConstructor
+    let pf5 = addNCastPtr pf4 4
+    writeInt32 pf5 memidDestructor
+    let pf6 = addNCastPtr pf5 4
+    writeWideString pf6 lpstrSchema
+    let pf7 = addNCastPtr pf6 4
+    writeWord32 pf7 cbSizeInstance
+    let pf8 = addNCastPtr pf7 4
+    writeEnum32 pf8 typekind
+    let pf9 = addNCastPtr pf8 4
+    writeWord16 pf9 cFuncs
+    let pf10 = addNCastPtr pf9 2
+    writeWord16 pf10 cVars
+    let pf11 = addNCastPtr pf10 2
+    writeWord16 pf11 cImplTypes
+    let pf12 = addNCastPtr pf11 2
+    writeWord16 pf12 cbSizeVft
+    let pf13 = addNCastPtr pf12 2
+    writeWord16 pf13 cbAlignment
+    let pf14 = addNCastPtr pf13 2
+    writeWord16 pf14 wTypeFlags
+    let pf15 = addNCastPtr pf14 2
+    writeWord16 pf15 wMajorVerNum
+    let pf16 = addNCastPtr pf15 2
+    writeWord16 pf16 wMinorVerNum
+    let pf17 = addNCastPtr pf16 2
+    writeTYPEDESC pf17 tdescAlias
+    let pf18 = addNCastPtr pf17 8
+    writeIDLDESC pf18 idldescType
+
+readTYPEATTR :: Bool
+             -> Ptr TYPEATTR
+             -> IO TYPEATTR
+readTYPEATTR finaliseMe__ ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    guid <- readGUID finaliseMe__ pf1
+    let pf2 = addNCastPtr pf1 16
+    lcid <- readWord32 pf2
+    let pf3 = addNCastPtr pf2 4
+    dwReserved0 <- readWord32 pf3
+    let pf4 = addNCastPtr pf3 4
+    memidConstructor <- readInt32 pf4
+    let pf5 = addNCastPtr pf4 4
+    memidDestructor <- readInt32 pf5
+    let pf6 = addNCastPtr pf5 4
+    lpstrSchema <- readWideString pf6
+    let pf7 = addNCastPtr pf6 4
+    cbSizeInstance <- readWord32 pf7
+    let pf8 = addNCastPtr pf7 4
+    typekind <- readEnum32 pf8
+    let pf9 = addNCastPtr pf8 4
+    cFuncs <- readWord16 pf9
+    let pf10 = addNCastPtr pf9 2
+    cVars <- readWord16 pf10
+    let pf11 = addNCastPtr pf10 2
+    cImplTypes <- readWord16 pf11
+    let pf12 = addNCastPtr pf11 2
+    cbSizeVft <- readWord16 pf12
+    let pf13 = addNCastPtr pf12 2
+    cbAlignment <- readWord16 pf13
+    let pf14 = addNCastPtr pf13 2
+    wTypeFlags <- readWord16 pf14
+    let pf15 = addNCastPtr pf14 2
+    wMajorVerNum <- readWord16 pf15
+    let pf16 = addNCastPtr pf15 2
+    wMinorVerNum <- readWord16 pf16
+    let pf17 = addNCastPtr pf16 2
+    tdescAlias <- readTYPEDESC pf17
+    let pf18 = addNCastPtr pf17 8
+    idldescType <- readIDLDESC pf18
+    return (TagTYPEATTR guid lcid dwReserved0 memidConstructor memidDestructor lpstrSchema cbSizeInstance typekind cFuncs cVars cImplTypes cbSizeVft cbAlignment wTypeFlags wMajorVerNum wMinorVerNum tdescAlias idldescType)
+
+sizeofTYPEATTR :: Word32
+sizeofTYPEATTR = 76
+
+type LPTYPEATTR = TYPEATTR
+data DISPPARAMS = TagDISPPARAMS {rgvarg :: [VARIANT],
+                                 rgdispidNamedArgs :: [Int32]}
+                    
+freeDISPPARAMS :: Ptr DISPPARAMS
+               -> IO ()
+freeDISPPARAMS ptr =
+  let
+   struct_ptr__ = addNCastPtr ptr 0
+  in
+  do
+    field_ptr__ <- derefPtr struct_ptr__
+    free field_ptr__
+
+writeDISPPARAMS :: Ptr DISPPARAMS
+                -> DISPPARAMS
+                -> IO ()
+writeDISPPARAMS ptr (TagDISPPARAMS rgvarg rgdispidNamedArgs) =
+  let
+   cArgs = (fromIntegral (length rgvarg) :: Word32)
+  in
+  do
+    rgvarg <- marshalllist sizeofVARIANT writeVARIANT rgvarg
+    let cNamedArgs = (fromIntegral (length rgdispidNamedArgs) :: Word32)
+    rgdispidNamedArgs <- marshalllist sizeofInt32 writeInt32 rgdispidNamedArgs
+    let pf0 = ptr
+        pf1 = addNCastPtr pf0 0
+    writePtr pf1 rgvarg
+    let pf2 = addNCastPtr pf1 4
+    writePtr pf2 rgdispidNamedArgs
+    let pf3 = addNCastPtr pf2 4
+    writeWord32 pf3 cArgs
+    let pf4 = addNCastPtr pf3 4
+    writeWord32 pf4 cNamedArgs
+
+readDISPPARAMS :: Ptr DISPPARAMS
+               -> IO DISPPARAMS
+readDISPPARAMS ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    rgvarg <- readPtr pf1
+    let pf2 = addNCastPtr pf1 4
+    rgdispidNamedArgs <- readPtr pf2
+    let pf3 = addNCastPtr pf2 4
+    cArgs <- readWord32 pf3
+    let pf4 = addNCastPtr pf3 4
+    cNamedArgs <- readWord32 pf4
+    cArgs <- unmarshallWord32 cArgs
+    cNamedArgs <- unmarshallWord32 cNamedArgs
+    rgvarg <- unmarshalllist sizeofVARIANT 0 ((fromIntegral cArgs :: Word32)) readVARIANT rgvarg
+    rgdispidNamedArgs <- unmarshalllist sizeofInt32 0 ((fromIntegral cNamedArgs :: Word32)) readInt32 rgdispidNamedArgs
+    return (TagDISPPARAMS rgvarg rgdispidNamedArgs)
+
+sizeofDISPPARAMS :: Word32
+sizeofDISPPARAMS = 16
+
+{- BEGIN_C_CODE
+#if 1
+END_C_CODE-}
+{- BEGIN_C_CODE
+/* the following is what MIDL knows how to remote */
+END_C_CODE-}
+data EXCEPINFO = TagEXCEPINFO {wCode :: WORD,
+                               wReserved :: WORD,
+                               bstrSource :: String,
+                               bstrDescription :: String,
+                               bstrHelpFile :: String,
+                               dwHelpContext :: DWORD,
+                               pvReserved :: ULONG,
+                               pfnDeferredFillIn :: ULONG,
+                               scode :: SCODE}
+                   
+freeEXCEPINFO :: Ptr EXCEPINFO
+              -> IO ()
+freeEXCEPINFO ptr =
+  do
+    let struct_ptr__ = addNCastPtr ptr 4
+    freeBSTR struct_ptr__
+    let struct_ptr__ = addNCastPtr ptr 8
+    freeBSTR struct_ptr__
+    let struct_ptr__ = addNCastPtr ptr 12
+    freeBSTR struct_ptr__
+
+writeEXCEPINFO :: Ptr EXCEPINFO
+               -> EXCEPINFO
+               -> IO ()
+writeEXCEPINFO ptr (TagEXCEPINFO wCode wReserved bstrSource bstrDescription bstrHelpFile dwHelpContext pvReserved pfnDeferredFillIn scode) =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    writeWord16 pf1 wCode
+    let pf2 = addNCastPtr pf1 2
+    writeWord16 pf2 wReserved
+    let pf3 = addNCastPtr pf2 2
+    writeBSTR pf3 bstrSource
+    let pf4 = addNCastPtr pf3 4
+    writeBSTR pf4 bstrDescription
+    let pf5 = addNCastPtr pf4 4
+    writeBSTR pf5 bstrHelpFile
+    let pf6 = addNCastPtr pf5 4
+    writeWord32 pf6 dwHelpContext
+    let pf7 = addNCastPtr pf6 4
+    writeWord32 pf7 pvReserved
+    let pf8 = addNCastPtr pf7 4
+    writeWord32 pf8 pfnDeferredFillIn
+    let pf9 = addNCastPtr pf8 4
+    writeInt32 pf9 scode
+
+readEXCEPINFO :: Ptr EXCEPINFO
+              -> IO EXCEPINFO
+readEXCEPINFO ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    wCode <- readWord16 pf1
+    let pf2 = addNCastPtr pf1 2
+    wReserved <- readWord16 pf2
+    let pf3 = addNCastPtr pf2 2
+    bstrSource <- readBSTR pf3
+    let pf4 = addNCastPtr pf3 4
+    bstrDescription <- readBSTR pf4
+    let pf5 = addNCastPtr pf4 4
+    bstrHelpFile <- readBSTR pf5
+    let pf6 = addNCastPtr pf5 4
+    dwHelpContext <- readWord32 pf6
+    let pf7 = addNCastPtr pf6 4
+    pvReserved <- readWord32 pf7
+    let pf8 = addNCastPtr pf7 4
+    pfnDeferredFillIn <- readWord32 pf8
+    let pf9 = addNCastPtr pf8 4
+    scode <- readInt32 pf9
+    return (TagEXCEPINFO wCode wReserved bstrSource bstrDescription bstrHelpFile dwHelpContext pvReserved pfnDeferredFillIn scode)
+
+sizeofEXCEPINFO :: Word32
+sizeofEXCEPINFO = 32
+
+{- BEGIN_C_CODE
+#else /* 0 */
+END_C_CODE-}
+{- BEGIN_C_CODE
+typedef struct tagEXCEPINFO {
+END_C_CODE-}
+{- BEGIN_C_CODE
+    WORD  wCode;
+END_C_CODE-}
+{- BEGIN_C_CODE
+    WORD  wReserved;
+END_C_CODE-}
+{- BEGIN_C_CODE
+    BSTR  bstrSource;
+END_C_CODE-}
+{- BEGIN_C_CODE
+    BSTR  bstrDescription;
+END_C_CODE-}
+{- BEGIN_C_CODE
+    BSTR  bstrHelpFile;
+END_C_CODE-}
+{- BEGIN_C_CODE
+    DWORD dwHelpContext;
+END_C_CODE-}
+{- BEGIN_C_CODE
+    PVOID pvReserved;
+END_C_CODE-}
+{- BEGIN_C_CODE
+    HRESULT (__stdcall *pfnDeferredFillIn)(struct tagEXCEPINFO *);
+END_C_CODE-}
+{- BEGIN_C_CODE
+    SCODE scode;
+END_C_CODE-}
+{- BEGIN_C_CODE
+} EXCEPINFO, * LPEXCEPINFO;
+END_C_CODE-}
+{- BEGIN_C_CODE
+#endif /* 0 */
+END_C_CODE-}
+data CALLCONV
+ = CC_FASTCALL
+ | CC_CDECL
+ | CC_MSCPASCAL
+ | CC_PASCAL
+ | CC_MACPASCAL
+ | CC_STDCALL
+ | CC_FPFASTCALL
+ | CC_SYSCALL
+ | CC_MPWCDECL
+ | CC_MPWPASCAL
+ | CC_MAX
+ 
+instance Enum (CALLCONV) where
+  fromEnum v =
+    case v of
+       CC_FASTCALL -> 0
+       CC_CDECL -> 1
+       CC_MSCPASCAL -> 2
+       CC_PASCAL -> 2
+       CC_MACPASCAL -> 3
+       CC_STDCALL -> 4
+       CC_FPFASTCALL -> 5
+       CC_SYSCALL -> 6
+       CC_MPWCDECL -> 7
+       CC_MPWPASCAL -> 8
+       CC_MAX -> 9
+  
+  toEnum v =
+    case v of
+       0 -> CC_FASTCALL
+       1 -> CC_CDECL
+       2 -> CC_MSCPASCAL
+       2 -> CC_PASCAL
+       3 -> CC_MACPASCAL
+       4 -> CC_STDCALL
+       5 -> CC_FPFASTCALL
+       6 -> CC_SYSCALL
+       7 -> CC_MPWCDECL
+       8 -> CC_MPWPASCAL
+       9 -> CC_MAX
+       _ -> error "unmarshallCALLCONV: illegal enum value "
+  
+data FUNCKIND
+ = FUNC_VIRTUAL
+ | FUNC_PUREVIRTUAL
+ | FUNC_NONVIRTUAL
+ | FUNC_STATIC
+ | FUNC_DISPATCH
+ deriving (Enum)
+data INVOKEKIND
+ = INVOKEKINDList__ [INVOKEKIND]
+ | INVOKE_FUNC
+ | INVOKE_PROPERTYGET
+ | INVOKE_PROPERTYPUT
+ | INVOKE_PROPERTYPUTREF
+ 
+instance Flags (INVOKEKIND) where
+  x1 .+. x2
+    = toEnum ((fromEnum x1 + fromEnum x2))
+  
+instance Enum (INVOKEKIND) where
+  fromEnum v =
+    case v of
+       (INVOKEKINDList__ xs) -> orList (map fromEnum xs)
+       INVOKE_FUNC -> 1
+       INVOKE_PROPERTYGET -> 2
+       INVOKE_PROPERTYPUT -> 4
+       INVOKE_PROPERTYPUTREF -> 8
+  
+  toEnum v =
+    case v of
+       1 -> INVOKE_FUNC
+       2 -> INVOKE_PROPERTYGET
+       4 -> INVOKE_PROPERTYPUT
+       8 -> INVOKE_PROPERTYPUTREF
+       x -> INVOKEKINDList__ (mapMaybe (\ val -> if ((val .&. fromIntegral x) == val)
+                                                   then Just (toEnum (fromIntegral val))
+                                                   else Nothing) (pow2Series 4 1))
+       _ -> error "unmarshallINVOKEKIND: illegal enum value "
+  
+data VARKIND
+ = VAR_PERINSTANCE
+ | VAR_STATIC
+ | VAR_CONST
+ | VAR_DISPATCH
+ deriving (Enum)
+data FUNCDESC = TagFUNCDESC {memid :: MEMBERID,
+                             lprgscode :: [Int32],
+                             lprgelemdescParam :: [ELEMDESC],
+                             funckind :: FUNCKIND,
+                             invkind :: INVOKEKIND,
+                             callconv :: CALLCONV,
+                             cParamsOpt :: SHORT,
+                             oVft :: SHORT,
+                             elemdescFunc :: ELEMDESC,
+                             wFuncFlags :: WORD}
+                  
+freeFUNCDESC :: Ptr FUNCDESC
+             -> IO ()
+freeFUNCDESC ptr =
+  do
+    let struct_ptr__ = addNCastPtr ptr 8
+    field_ptr__ <- derefPtr struct_ptr__
+    free field_ptr__
+    let struct_ptr__ = addNCastPtr ptr 32
+    trivialFree struct_ptr__
+
+writeFUNCDESC :: Ptr FUNCDESC
+              -> FUNCDESC
+              -> IO ()
+writeFUNCDESC ptr (TagFUNCDESC memid lprgscode lprgelemdescParam funckind invkind callconv cParamsOpt oVft elemdescFunc wFuncFlags) =
+  let
+   cScodes = (fromIntegral (length lprgscode) :: Int16)
+  in
+  do
+    lprgscode <- marshalllist sizeofInt32 writeInt32 lprgscode
+    let cParams = (fromIntegral (length lprgelemdescParam) :: Int16)
+    lprgelemdescParam <- marshalllist sizeofELEMDESC writeELEMDESC lprgelemdescParam
+    let pf0 = ptr
+        pf1 = addNCastPtr pf0 0
+    writeInt32 pf1 memid
+    let pf2 = addNCastPtr pf1 4
+    writePtr pf2 lprgscode
+    let pf3 = addNCastPtr pf2 4
+    writePtr pf3 lprgelemdescParam
+    let pf4 = addNCastPtr pf3 4
+    writeEnum32 pf4 funckind
+    let pf5 = addNCastPtr pf4 4
+    writeEnum32 pf5 invkind
+    let pf6 = addNCastPtr pf5 4
+    writeEnum32 pf6 callconv
+    let pf7 = addNCastPtr pf6 4
+    writeInt16 pf7 cParams
+    let pf8 = addNCastPtr pf7 2
+    writeInt16 pf8 cParamsOpt
+    let pf9 = addNCastPtr pf8 2
+    writeInt16 pf9 oVft
+    let pf10 = addNCastPtr pf9 2
+    writeInt16 pf10 cScodes
+    let pf11 = addNCastPtr pf10 2
+    writeELEMDESC pf11 elemdescFunc
+    let pf12 = addNCastPtr pf11 16
+    writeWord16 pf12 wFuncFlags
+
+readFUNCDESC :: Ptr FUNCDESC
+             -> IO FUNCDESC
+readFUNCDESC ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    memid <- readInt32 pf1
+    let pf2 = addNCastPtr pf1 4
+    lprgscode <- readPtr pf2
+    let pf3 = addNCastPtr pf2 4
+    lprgelemdescParam <- readPtr pf3
+    let pf4 = addNCastPtr pf3 4
+    funckind <- readEnum32 pf4
+    let pf5 = addNCastPtr pf4 4
+    invkind <- readEnum32 pf5
+    let pf6 = addNCastPtr pf5 4
+    callconv <- readEnum32 pf6
+    let pf7 = addNCastPtr pf6 4
+    cParams <- readInt16 pf7
+    let pf8 = addNCastPtr pf7 2
+    cParamsOpt <- readInt16 pf8
+    let pf9 = addNCastPtr pf8 2
+    oVft <- readInt16 pf9
+    let pf10 = addNCastPtr pf9 2
+    cScodes <- readInt16 pf10
+    let pf11 = addNCastPtr pf10 2
+    elemdescFunc <- readELEMDESC pf11
+    let pf12 = addNCastPtr pf11 16
+    wFuncFlags <- readWord16 pf12
+    cScodes <- unmarshallInt16 cScodes
+    cParams <- unmarshallInt16 cParams
+    lprgscode <- unmarshalllist sizeofInt32 0 ((fromIntegral cScodes :: Word32)) readInt32 lprgscode
+    lprgelemdescParam <- unmarshalllist sizeofELEMDESC 0 ((fromIntegral cParams :: Word32)) readELEMDESC lprgelemdescParam
+    return (TagFUNCDESC memid lprgscode lprgelemdescParam funckind invkind callconv cParamsOpt oVft elemdescFunc wFuncFlags)
+
+sizeofFUNCDESC :: Word32
+sizeofFUNCDESC = 52
+
+type LPFUNCDESC = FUNCDESC
+iMPLTYPEFLAG_FDEFAULT :: USHORT
+iMPLTYPEFLAG_FDEFAULT = 0x1
+
+iMPLTYPEFLAG_FSOURCE :: USHORT
+iMPLTYPEFLAG_FSOURCE = 0x2
+
+iMPLTYPEFLAG_FRESTRICTED :: USHORT
+iMPLTYPEFLAG_FRESTRICTED = 0x4
+
+iMPLTYPEFLAG_FDEFAULTVTABLE :: USHORT
+iMPLTYPEFLAG_FDEFAULTVTABLE = 0x8
+
+data IHC_TAG_9
+ = OInst ULONG
+ | LpvarValue (Maybe VARIANT)
+ 
+marshallIHC_TAG_9 :: IHC_TAG_9
+                  -> IO (IHC_TAG_9, Int32)
+marshallIHC_TAG_9 = marshallUnion "marshallIHC_TAG_9"
+
+unmarshallIHC_TAG_9 :: IHC_TAG_9
+                    -> Int32
+                    -> IO IHC_TAG_9
+unmarshallIHC_TAG_9 = unmarshallUnion "unmarshallIHC_TAG_9"
+
+writeIHC_TAG_9 :: (Int32 -> IO ())
+               -> Ptr IHC_TAG_9
+               -> IHC_TAG_9
+               -> IO ()
+writeIHC_TAG_9 write_tag ptr v =
+  case v of
+     (OInst oInst) -> do
+                        write_tag 0
+                        writeWord32 (castPtr ptr) oInst
+     (LpvarValue lpvarValue) -> do
+                                  write_tag 2
+                                  writeMaybe writeVARIANT (castPtr ptr) lpvarValue
+
+readIHC_TAG_9 :: IO Int32
+              -> Ptr IHC_TAG_9
+              -> IO IHC_TAG_9
+readIHC_TAG_9 read_tag ptr =
+  do
+    tag <- read_tag
+    case tag of
+       0 -> do
+              v <- readWord32 (castPtr ptr)
+              return (OInst v)
+       3 -> do
+              v <- readWord32 (castPtr ptr)
+              return (OInst v)
+       1 -> do
+              v <- readWord32 (castPtr ptr)
+              return (OInst v)
+       2 -> do
+              v <- readMaybe readVARIANT (castPtr ptr)
+              return (LpvarValue v)
+
+sizeofIHC_TAG_9 :: Word32
+sizeofIHC_TAG_9 = 4
+
+freeIHC_TAG_9 :: Int32
+              -> Ptr IHC_TAG_9
+              -> IO ()
+freeIHC_TAG_9 read_tag ptr =
+  do
+    tag <- return (read_tag)
+    case tag of
+       0 -> return ()
+       3 -> return ()
+       1 -> return ()
+       2 -> free (castPtr ptr)
+
+type IHC_TAG_8 = IHC_TAG_9
+data VARDESC = TagVARDESC {memid0 :: MEMBERID,
+                           lpstrSchema0 :: LPOLESTR,
+                           iHC_TAG_7 :: IHC_TAG_9,
+                           elemdescVar :: ELEMDESC,
+                           wVarFlags :: WORD,
+                           varkind :: VARKIND}
+                 
+freeVARDESC :: Ptr VARDESC
+            -> IO ()
+freeVARDESC ptr =
+  do
+    varkind <- readInt32 (addNCastPtr ptr 32)
+    return ()
+    let struct_ptr__ = addNCastPtr ptr 4
+    trivialFree struct_ptr__
+    let struct_ptr__ = addNCastPtr ptr 8
+    trivialFree struct_ptr__
+    let struct_ptr__ = addNCastPtr ptr 12
+    trivialFree struct_ptr__
+
+writeVARDESC :: Ptr VARDESC
+             -> VARDESC
+             -> IO ()
+writeVARDESC ptr (TagVARDESC memid0 lpstrSchema0 iHC_TAG_7 elemdescVar wVarFlags varkind) =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    writeInt32 pf1 memid0
+    let pf2 = addNCastPtr pf1 4
+    writeWideString pf2 lpstrSchema0
+    let pf3 = addNCastPtr pf2 4
+    writeIHC_TAG_9 (writeInt32 (addNCastPtr pf0 32)) pf3 iHC_TAG_7
+    let pf4 = addNCastPtr pf3 4
+    writeELEMDESC pf4 elemdescVar
+    let pf5 = addNCastPtr pf4 16
+    writeWord16 pf5 wVarFlags
+    let pf6 = addNCastPtr pf5 4
+    writeEnum32 pf6 varkind
+
+readVARDESC :: Ptr VARDESC
+            -> IO VARDESC
+readVARDESC ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    memid0 <- readInt32 pf1
+    let pf2 = addNCastPtr pf1 4
+    lpstrSchema0 <- readWideString pf2
+    let pf3 = addNCastPtr pf2 4
+    iHC_TAG_7 <- readIHC_TAG_9 (readInt32 (addNCastPtr pf0 32)) pf3
+    let pf4 = addNCastPtr pf3 4
+    elemdescVar <- readELEMDESC pf4
+    let pf5 = addNCastPtr pf4 16
+    wVarFlags <- readWord16 pf5
+    let pf6 = addNCastPtr pf5 4
+    varkind <- readEnum32 pf6
+    return (TagVARDESC memid0 lpstrSchema0 iHC_TAG_7 elemdescVar wVarFlags varkind)
+
+sizeofVARDESC :: Word32
+sizeofVARDESC = 36
+
+type LPVARDESC = VARDESC
+data TYPEFLAGS
+ = TYPEFLAGSList__ [TYPEFLAGS]
+ | TYPEFLAG_FAPPOBJECT
+ | TYPEFLAG_FCANCREATE
+ | TYPEFLAG_FLICENSED
+ | TYPEFLAG_FPREDECLID
+ | TYPEFLAG_FHIDDEN
+ | TYPEFLAG_FCONTROL
+ | TYPEFLAG_FDUAL
+ | TYPEFLAG_FNONEXTENSIBLE
+ | TYPEFLAG_FOLEAUTOMATION
+ | TYPEFLAG_FRESTRICTED
+ | TYPEFLAG_FAGGREGATABLE
+ | TYPEFLAG_FREPLACEABLE
+ | TYPEFLAG_FDISPATCHABLE
+ | TYPEFLAG_FREVERSEBIND
+ 
+instance Flags (TYPEFLAGS) where
+  x1 .+. x2
+    = toEnum ((fromEnum x1 + fromEnum x2))
+  
+instance Enum (TYPEFLAGS) where
+  fromEnum v =
+    case v of
+       (TYPEFLAGSList__ xs) -> orList (map fromEnum xs)
+       TYPEFLAG_FAPPOBJECT -> 1
+       TYPEFLAG_FCANCREATE -> 2
+       TYPEFLAG_FLICENSED -> 4
+       TYPEFLAG_FPREDECLID -> 8
+       TYPEFLAG_FHIDDEN -> 16
+       TYPEFLAG_FCONTROL -> 32
+       TYPEFLAG_FDUAL -> 64
+       TYPEFLAG_FNONEXTENSIBLE -> 128
+       TYPEFLAG_FOLEAUTOMATION -> 256
+       TYPEFLAG_FRESTRICTED -> 512
+       TYPEFLAG_FAGGREGATABLE -> 1024
+       TYPEFLAG_FREPLACEABLE -> 2048
+       TYPEFLAG_FDISPATCHABLE -> 4096
+       TYPEFLAG_FREVERSEBIND -> 8192
+  
+  toEnum v =
+    case v of
+       1 -> TYPEFLAG_FAPPOBJECT
+       2 -> TYPEFLAG_FCANCREATE
+       4 -> TYPEFLAG_FLICENSED
+       8 -> TYPEFLAG_FPREDECLID
+       16 -> TYPEFLAG_FHIDDEN
+       32 -> TYPEFLAG_FCONTROL
+       64 -> TYPEFLAG_FDUAL
+       128 -> TYPEFLAG_FNONEXTENSIBLE
+       256 -> TYPEFLAG_FOLEAUTOMATION
+       512 -> TYPEFLAG_FRESTRICTED
+       1024 -> TYPEFLAG_FAGGREGATABLE
+       2048 -> TYPEFLAG_FREPLACEABLE
+       4096 -> TYPEFLAG_FDISPATCHABLE
+       8192 -> TYPEFLAG_FREVERSEBIND
+       x -> TYPEFLAGSList__ (mapMaybe (\ val -> if ((val .&. fromIntegral x) == val)
+                                                  then Just (toEnum (fromIntegral val))
+                                                  else Nothing) (pow2Series 14 1))
+       _ -> error "unmarshallTYPEFLAGS: illegal enum value "
+  
+data FUNCFLAGS
+ = FUNCFLAGSList__ [FUNCFLAGS]
+ | FUNCFLAG_FRESTRICTED
+ | FUNCFLAG_FSOURCE
+ | FUNCFLAG_FBINDABLE
+ | FUNCFLAG_FREQUESTEDIT
+ | FUNCFLAG_FDISPLAYBIND
+ | FUNCFLAG_FDEFAULTBIND
+ | FUNCFLAG_FHIDDEN
+ | FUNCFLAG_FUSESGETLASTERROR
+ | FUNCFLAG_FDEFAULTCOLLELEM
+ | FUNCFLAG_FUIDEFAULT
+ | FUNCFLAG_FNONBROWSABLE
+ | FUNCFLAG_FREPLACEABLE
+ | FUNCFLAG_FIMMEDIATEBIND
+ 
+instance Flags (FUNCFLAGS) where
+  x1 .+. x2
+    = toEnum ((fromEnum x1 + fromEnum x2))
+  
+instance Enum (FUNCFLAGS) where
+  fromEnum v =
+    case v of
+       (FUNCFLAGSList__ xs) -> orList (map fromEnum xs)
+       FUNCFLAG_FRESTRICTED -> 1
+       FUNCFLAG_FSOURCE -> 2
+       FUNCFLAG_FBINDABLE -> 4
+       FUNCFLAG_FREQUESTEDIT -> 8
+       FUNCFLAG_FDISPLAYBIND -> 16
+       FUNCFLAG_FDEFAULTBIND -> 32
+       FUNCFLAG_FHIDDEN -> 64
+       FUNCFLAG_FUSESGETLASTERROR -> 128
+       FUNCFLAG_FDEFAULTCOLLELEM -> 256
+       FUNCFLAG_FUIDEFAULT -> 512
+       FUNCFLAG_FNONBROWSABLE -> 1024
+       FUNCFLAG_FREPLACEABLE -> 2048
+       FUNCFLAG_FIMMEDIATEBIND -> 4096
+  
+  toEnum v =
+    case v of
+       1 -> FUNCFLAG_FRESTRICTED
+       2 -> FUNCFLAG_FSOURCE
+       4 -> FUNCFLAG_FBINDABLE
+       8 -> FUNCFLAG_FREQUESTEDIT
+       16 -> FUNCFLAG_FDISPLAYBIND
+       32 -> FUNCFLAG_FDEFAULTBIND
+       64 -> FUNCFLAG_FHIDDEN
+       128 -> FUNCFLAG_FUSESGETLASTERROR
+       256 -> FUNCFLAG_FDEFAULTCOLLELEM
+       512 -> FUNCFLAG_FUIDEFAULT
+       1024 -> FUNCFLAG_FNONBROWSABLE
+       2048 -> FUNCFLAG_FREPLACEABLE
+       4096 -> FUNCFLAG_FIMMEDIATEBIND
+       x -> FUNCFLAGSList__ (mapMaybe (\ val -> if ((val .&. fromIntegral x) == val)
+                                                  then Just (toEnum (fromIntegral val))
+                                                  else Nothing) (pow2Series 13 1))
+       _ -> error "unmarshallFUNCFLAGS: illegal enum value "
+  
+data VARFLAGS
+ = VARFLAGSList__ [VARFLAGS]
+ | VARFLAG_FREADONLY
+ | VARFLAG_FSOURCE
+ | VARFLAG_FBINDABLE
+ | VARFLAG_FREQUESTEDIT
+ | VARFLAG_FDISPLAYBIND
+ | VARFLAG_FDEFAULTBIND
+ | VARFLAG_FHIDDEN
+ | VARFLAG_FRESTRICTED
+ | VARFLAG_FDEFAULTCOLLELEM
+ | VARFLAG_FUIDEFAULT
+ | VARFLAG_FNONBROWSABLE
+ | VARFLAG_FREPLACEABLE
+ | VARFLAG_FIMMEDIATEBIND
+ 
+instance Flags (VARFLAGS) where
+  x1 .+. x2
+    = toEnum ((fromEnum x1 + fromEnum x2))
+  
+instance Enum (VARFLAGS) where
+  fromEnum v =
+    case v of
+       (VARFLAGSList__ xs) -> orList (map fromEnum xs)
+       VARFLAG_FREADONLY -> 1
+       VARFLAG_FSOURCE -> 2
+       VARFLAG_FBINDABLE -> 4
+       VARFLAG_FREQUESTEDIT -> 8
+       VARFLAG_FDISPLAYBIND -> 16
+       VARFLAG_FDEFAULTBIND -> 32
+       VARFLAG_FHIDDEN -> 64
+       VARFLAG_FRESTRICTED -> 128
+       VARFLAG_FDEFAULTCOLLELEM -> 256
+       VARFLAG_FUIDEFAULT -> 512
+       VARFLAG_FNONBROWSABLE -> 1024
+       VARFLAG_FREPLACEABLE -> 2048
+       VARFLAG_FIMMEDIATEBIND -> 4096
+  
+  toEnum v =
+    case v of
+       1 -> VARFLAG_FREADONLY
+       2 -> VARFLAG_FSOURCE
+       4 -> VARFLAG_FBINDABLE
+       8 -> VARFLAG_FREQUESTEDIT
+       16 -> VARFLAG_FDISPLAYBIND
+       32 -> VARFLAG_FDEFAULTBIND
+       64 -> VARFLAG_FHIDDEN
+       128 -> VARFLAG_FRESTRICTED
+       256 -> VARFLAG_FDEFAULTCOLLELEM
+       512 -> VARFLAG_FUIDEFAULT
+       1024 -> VARFLAG_FNONBROWSABLE
+       2048 -> VARFLAG_FREPLACEABLE
+       4096 -> VARFLAG_FIMMEDIATEBIND
+       x -> VARFLAGSList__ (mapMaybe (\ val -> if ((val .&. fromIntegral x) == val)
+                                                 then Just (toEnum (fromIntegral val))
+                                                 else Nothing) (pow2Series 13 1))
+       _ -> error "unmarshallVARFLAGS: illegal enum value "
+  
+data CLEANLOCALSTORAGE = TagCLEANLOCALSTORAGE {pInterface :: (IUnknown ()),
+                                               pStorage :: PVOID,
+                                               flags :: DWORD}
+                           
+writeCLEANLOCALSTORAGE :: Bool
+                       -> Ptr CLEANLOCALSTORAGE
+                       -> CLEANLOCALSTORAGE
+                       -> IO ()
+writeCLEANLOCALSTORAGE addRefMe__ ptr (TagCLEANLOCALSTORAGE pInterface pStorage flags) =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    writeIUnknown addRefMe__ pf1 pInterface
+    let pf2 = addNCastPtr pf1 4
+    writePtr pf2 pStorage
+    let pf3 = addNCastPtr pf2 4
+    writeWord32 pf3 flags
+
+readCLEANLOCALSTORAGE :: Bool
+                      -> Ptr CLEANLOCALSTORAGE
+                      -> IO CLEANLOCALSTORAGE
+readCLEANLOCALSTORAGE finaliseMe__ ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    pInterface <- readIUnknown finaliseMe__ pf1
+    let pf2 = addNCastPtr pf1 4
+    pStorage <- readPtr pf2
+    let pf3 = addNCastPtr pf2 4
+    flags <- readWord32 pf3
+    return (TagCLEANLOCALSTORAGE pInterface pStorage flags)
+
+sizeofCLEANLOCALSTORAGE :: Word32
+sizeofCLEANLOCALSTORAGE = 12
+
+data CUSTDATAITEM = TagCUSTDATAITEM {guid0 :: GUID,
+                                     varValue :: VARIANT}
+                      
+freeCUSTDATAITEM :: Ptr CUSTDATAITEM
+                 -> IO ()
+freeCUSTDATAITEM ptr =
+  let
+   struct_ptr__ = addNCastPtr ptr 16
+  in
+  trivialFree struct_ptr__
+
+writeCUSTDATAITEM :: Ptr CUSTDATAITEM
+                  -> CUSTDATAITEM
+                  -> IO ()
+writeCUSTDATAITEM ptr (TagCUSTDATAITEM guid0 varValue) =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    writeGUID pf1 guid0
+    let pf2 = addNCastPtr pf1 16
+    copyVARIANT pf2 varValue
+
+readCUSTDATAITEM :: Bool
+                 -> Ptr CUSTDATAITEM
+                 -> IO CUSTDATAITEM
+readCUSTDATAITEM finaliseMe__ ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    guid0 <- readGUID finaliseMe__ pf1
+    let pf2 = addNCastPtr pf1 16
+    varValue <- unmarshallVARIANT pf2
+    return (TagCUSTDATAITEM guid0 varValue)
+
+sizeofCUSTDATAITEM :: Word32
+sizeofCUSTDATAITEM = 32
+
+type LPCUSTDATAITEM = CUSTDATAITEM
+data CUSTDATA = TagCUSTDATA {prgCustData :: [CUSTDATAITEM]}
+                  
+freeCUSTDATA :: Ptr CUSTDATA
+             -> IO ()
+freeCUSTDATA ptr =
+  let
+   struct_ptr__ = addNCastPtr ptr 4
+  in
+  trivialFree struct_ptr__
+
+writeCUSTDATA :: Ptr CUSTDATA
+              -> CUSTDATA
+              -> IO ()
+writeCUSTDATA ptr (TagCUSTDATA prgCustData) =
+  let
+   cCustData = (fromIntegral (length prgCustData) :: Word32)
+  in
+  do
+    prgCustData <- marshalllist sizeofCUSTDATAITEM writeCUSTDATAITEM prgCustData
+    let pf0 = ptr
+        pf1 = addNCastPtr pf0 0
+    writeWord32 pf1 cCustData
+    let pf2 = addNCastPtr pf1 4
+    writePtr pf2 prgCustData
+
+readCUSTDATA :: Bool
+             -> Ptr CUSTDATA
+             -> IO CUSTDATA
+readCUSTDATA finaliseMe__ ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    cCustData <- readWord32 pf1
+    let pf2 = addNCastPtr pf1 4
+    prgCustData <- readPtr pf2
+    cCustData <- unmarshallWord32 cCustData
+    prgCustData <- unmarshalllist sizeofCUSTDATAITEM 0 ((fromIntegral cCustData :: Word32)) (readCUSTDATAITEM finaliseMe__) prgCustData
+    return (TagCUSTDATA prgCustData)
+
+sizeofCUSTDATA :: Word32
+sizeofCUSTDATA = 8
+
+type LPCUSTDATA = CUSTDATA
+-- --------------------------------------------------
+-- 
+-- interface ICreateTypeInfo
+-- 
+-- --------------------------------------------------
+data ICreateTypeInfo_ a = ICreateTypeInfo__
+                            
+type ICreateTypeInfo a = IUnknown (ICreateTypeInfo_ a)
+iidICreateTypeInfo :: IID (ICreateTypeInfo ())
+iidICreateTypeInfo = mkIID "{00020405-0000-0000-C000-000000000046}"
+
+type LPCREATETYPEINFO = Maybe (ICreateTypeInfo ())
+setGuid :: REFGUID
+        -> ICreateTypeInfo a0
+        -> IO ()
+setGuid guid1 iptr =
+  do
+    guid1 <- marshallGUID guid1
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr guid1 (\ guid1 -> prim_System_Win32_Com_Automation_TypeLib_setGuid methPtr iptr guid1)) 3 iptr
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_setGuid :: Ptr () -> Ptr () -> Ptr GUID -> IO Int32
+setTypeFlags :: UINT
+             -> ICreateTypeInfo a0
+             -> IO ()
+setTypeFlags uTypeFlags iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_setTypeFlags methPtr iptr uTypeFlags)
+                 4
+                 iptr
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_setTypeFlags :: Ptr () -> Ptr () -> Word32 -> IO Int32
+setDocString :: LPOLESTR
+             -> ICreateTypeInfo a0
+             -> IO ()
+setDocString pStrDoc iptr =
+  do
+    pStrDoc <- marshallWideString pStrDoc
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_setDocString methPtr iptr pStrDoc) 5 iptr
+    freeWideString pStrDoc
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_setDocString :: Ptr () -> Ptr () -> Ptr WideString -> IO Int32
+setHelpContext :: DWORD
+               -> ICreateTypeInfo a0
+               -> IO ()
+setHelpContext dwHelpContext0 iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_setTypeFlags methPtr iptr dwHelpContext0)
+                 6
+                 iptr
+
+setVersion :: WORD
+           -> WORD
+           -> ICreateTypeInfo a0
+           -> IO ()
+setVersion wMajorVerNum0 wMinorVerNum0 iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_setVersion methPtr iptr wMajorVerNum0 wMinorVerNum0)
+                 7
+                 iptr
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_setVersion :: Ptr () -> Ptr () -> Word16 -> Word16 -> IO Int32
+addRefTypeInfo :: ITypeInfo a1
+               -> ICreateTypeInfo a0
+               -> IO HREFTYPE
+addRefTypeInfo pTInfo iptr =
+  do
+    phRefType <- allocBytes (fromIntegral sizeofWord32)
+    pTInfo <- marshallIUnknown pTInfo
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr pTInfo (\ pTInfo -> prim_System_Win32_Com_Automation_TypeLib_addRefTypeInfo methPtr iptr pTInfo phRefType)) 8 iptr
+    doThenFree free readWord32 phRefType
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_addRefTypeInfo :: Ptr () -> Ptr () -> Ptr (ITypeInfo a) -> Ptr Word32 -> IO Int32
+addFuncDesc :: UINT
+            -> FUNCDESC
+            -> ICreateTypeInfo a0
+            -> IO ()
+addFuncDesc index pFuncDesc iptr =
+  do
+    pFuncDesc <- marshallref (allocBytes (fromIntegral sizeofFUNCDESC)) writeFUNCDESC pFuncDesc
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_addFuncDesc methPtr iptr index pFuncDesc) 9 iptr
+    free pFuncDesc
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_addFuncDesc :: Ptr () -> Ptr () -> Word32 -> Ptr FUNCDESC -> IO Int32
+addImplType :: UINT
+            -> HREFTYPE
+            -> ICreateTypeInfo a0
+            -> IO ()
+addImplType index hRefType iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_addImplType methPtr iptr index hRefType)
+                 10
+                 iptr
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_addImplType :: Ptr () -> Ptr () -> Word32 -> Word32 -> IO Int32
+setImplTypeFlags :: UINT
+                 -> INT
+                 -> ICreateTypeInfo a0
+                 -> IO ()
+setImplTypeFlags index implTypeFlags iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_setImplTypeFlags methPtr iptr index implTypeFlags)
+                 11
+                 iptr
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_setImplTypeFlags :: Ptr () -> Ptr () -> Word32 -> Int32 -> IO Int32
+setAlignment :: WORD
+             -> ICreateTypeInfo a0
+             -> IO ()
+setAlignment cbAlignment0 iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_setAlignment methPtr iptr cbAlignment0)
+                 12
+                 iptr
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_setAlignment :: Ptr () -> Ptr () -> Word16 -> IO Int32
+setSchema :: LPOLESTR
+          -> ICreateTypeInfo a0
+          -> IO ()
+setSchema pStrSchema iptr =
+  do
+    pStrSchema <- marshallWideString pStrSchema
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_setDocString methPtr iptr pStrSchema) 13 iptr
+    freeWideString pStrSchema
+
+addVarDesc :: UINT
+           -> VARDESC
+           -> ICreateTypeInfo a0
+           -> IO ()
+addVarDesc index pVarDesc iptr =
+  do
+    pVarDesc <- marshallref (allocBytes (fromIntegral sizeofVARDESC)) writeVARDESC pVarDesc
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_addVarDesc methPtr iptr index pVarDesc) 14 iptr
+    free pVarDesc
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_addVarDesc :: Ptr () -> Ptr () -> Word32 -> Ptr VARDESC -> IO Int32
+setFuncAndParamNames :: UINT
+                     -> [LPOLESTR]
+                     -> ICreateTypeInfo a0
+                     -> IO ()
+setFuncAndParamNames index rgszNames iptr =
+  let
+   cNames = (fromIntegral (length rgszNames) :: Word32)
+  in
+  do
+    rgszNames <- marshalllist sizeofPtr writeWideString rgszNames
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_setFuncAndParamNames methPtr iptr index rgszNames cNames) 15 iptr
+    free rgszNames
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_setFuncAndParamNames :: Ptr () -> Ptr () -> Word32 -> Ptr (Ptr WideString) -> Word32 -> IO Int32
+setVarName :: UINT
+           -> LPOLESTR
+           -> ICreateTypeInfo a0
+           -> IO ()
+setVarName index szName iptr =
+  do
+    szName <- marshallWideString szName
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_setVarName methPtr iptr index szName) 16 iptr
+    freeWideString szName
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_setVarName :: Ptr () -> Ptr () -> Word32 -> Ptr WideString -> IO Int32
+setTypeDescAlias :: TYPEDESC
+                 -> ICreateTypeInfo a0
+                 -> IO ()
+setTypeDescAlias pTDescAlias iptr =
+  do
+    pTDescAlias <- marshallref (allocBytes (fromIntegral sizeofTYPEDESC)) writeTYPEDESC pTDescAlias
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_setTypeDescAlias methPtr iptr pTDescAlias) 17 iptr
+    free pTDescAlias
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_setTypeDescAlias :: Ptr () -> Ptr () -> Ptr TYPEDESC -> IO Int32
+defineFuncAsDllEntry :: UINT
+                     -> LPOLESTR
+                     -> LPOLESTR
+                     -> ICreateTypeInfo a0
+                     -> IO ()
+defineFuncAsDllEntry index szDllName szProcName iptr =
+  do
+    szDllName <- marshallWideString szDllName
+    szProcName <- marshallWideString szProcName
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_defineFuncAsDllEntry methPtr iptr index szDllName szProcName) 18 iptr
+    freeWideString szDllName
+    freeWideString szProcName
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_defineFuncAsDllEntry :: Ptr () -> Ptr () -> Word32 -> Ptr WideString -> Ptr WideString -> IO Int32
+setFuncDocString :: UINT
+                 -> LPOLESTR
+                 -> ICreateTypeInfo a0
+                 -> IO ()
+setFuncDocString index szDocString iptr =
+  do
+    szDocString <- marshallWideString szDocString
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_setVarName methPtr iptr index szDocString) 19 iptr
+    freeWideString szDocString
+
+setVarDocString :: UINT
+                -> LPOLESTR
+                -> ICreateTypeInfo a0
+                -> IO ()
+setVarDocString index szDocString iptr =
+  do
+    szDocString <- marshallWideString szDocString
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_setVarName methPtr iptr index szDocString) 20 iptr
+    freeWideString szDocString
+
+setFuncHelpContext :: UINT
+                   -> DWORD
+                   -> ICreateTypeInfo a0
+                   -> IO ()
+setFuncHelpContext index dwHelpContext0 iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_addImplType methPtr iptr index dwHelpContext0)
+                 21
+                 iptr
+
+setVarHelpContext :: UINT
+                  -> DWORD
+                  -> ICreateTypeInfo a0
+                  -> IO ()
+setVarHelpContext index dwHelpContext0 iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_addImplType methPtr iptr index dwHelpContext0)
+                 22
+                 iptr
+
+setMops :: UINT
+        -> String
+        -> ICreateTypeInfo a0
+        -> IO ()
+setMops index bstrMops iptr =
+  do
+    bstrMops <- marshallBSTR bstrMops
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_setMops methPtr iptr index bstrMops) 23 iptr
+    freeBSTR bstrMops
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_setMops :: Ptr () -> Ptr () -> Word32 -> Ptr String -> IO Int32
+setTypeIdldesc :: IDLDESC
+               -> ICreateTypeInfo a0
+               -> IO ()
+setTypeIdldesc pIdlDesc iptr =
+  do
+    pIdlDesc <- marshallref (allocBytes (fromIntegral sizeofIDLDESC)) writeIDLDESC pIdlDesc
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_setTypeIdldesc methPtr iptr pIdlDesc) 24 iptr
+    free pIdlDesc
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_setTypeIdldesc :: Ptr () -> Ptr () -> Ptr IDLDESC -> IO Int32
+layOut :: ICreateTypeInfo a0
+       -> IO ()
+layOut iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_layOut methPtr iptr)
+                 25
+                 iptr
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_layOut :: Ptr () -> Ptr () -> IO Int32
+-- --------------------------------------------------
+-- 
+-- interface ICreateTypeInfo2
+-- 
+-- --------------------------------------------------
+data ICreateTypeInfo2_ a = ICreateTypeInfo2__
+                             
+type ICreateTypeInfo2 a = ICreateTypeInfo (ICreateTypeInfo2_ a)
+iidICreateTypeInfo2 :: IID (ICreateTypeInfo2 ())
+iidICreateTypeInfo2 =
+  mkIID "{0002040E-0000-0000-C000-000000000046}"
+
+type LPCREATETYPEINFO2 = Maybe (ICreateTypeInfo2 ())
+deleteFuncDesc :: UINT
+               -> ICreateTypeInfo2 a0
+               -> IO ()
+deleteFuncDesc index iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_setTypeFlags methPtr iptr index)
+                 26
+                 iptr
+
+deleteFuncDescByMemId :: MEMBERID
+                      -> INVOKEKIND
+                      -> ICreateTypeInfo2 a0
+                      -> IO ()
+deleteFuncDescByMemId memid1 invKind iptr =
+  do
+    invKind <- marshallEnum32 invKind
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_deleteFuncDescByMemId methPtr iptr memid1 invKind) 27 iptr
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_deleteFuncDescByMemId :: Ptr () -> Ptr () -> Int32 -> Int32 -> IO Int32
+deleteVarDesc :: UINT
+              -> ICreateTypeInfo2 a0
+              -> IO ()
+deleteVarDesc index iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_setTypeFlags methPtr iptr index)
+                 28
+                 iptr
+
+deleteVarDescByMemId :: MEMBERID
+                     -> ICreateTypeInfo2 a0
+                     -> IO ()
+deleteVarDescByMemId memid1 iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_deleteVarDescByMemId methPtr iptr memid1)
+                 29
+                 iptr
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_deleteVarDescByMemId :: Ptr () -> Ptr () -> Int32 -> IO Int32
+deleteImplType :: UINT
+               -> ICreateTypeInfo2 a0
+               -> IO ()
+deleteImplType index iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_setTypeFlags methPtr iptr index)
+                 30
+                 iptr
+
+setCustData :: REFGUID
+            -> VARIANT
+            -> ICreateTypeInfo2 a0
+            -> IO ()
+setCustData guid1 pVarVal iptr =
+  do
+    guid1 <- marshallGUID guid1
+    pVarVal <- marshallVARIANT pVarVal
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr guid1 (\ guid1 -> prim_System_Win32_Com_Automation_TypeLib_setCustData methPtr iptr guid1 pVarVal)) 31 iptr
+    free pVarVal
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_setCustData :: Ptr () -> Ptr () -> Ptr GUID -> VARIANT -> IO Int32
+setFuncCustData :: UINT
+                -> REFGUID
+                -> VARIANT
+                -> ICreateTypeInfo2 a0
+                -> IO ()
+setFuncCustData index guid1 pVarVal iptr =
+  do
+    guid1 <- marshallGUID guid1
+    pVarVal <- marshallVARIANT pVarVal
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr guid1 (\ guid1 -> prim_System_Win32_Com_Automation_TypeLib_setFuncCustData methPtr iptr index guid1 pVarVal)) 32 iptr
+    free pVarVal
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_setFuncCustData :: Ptr () -> Ptr () -> Word32 -> Ptr GUID -> VARIANT -> IO Int32
+setParamCustData :: UINT
+                 -> UINT
+                 -> REFGUID
+                 -> VARIANT
+                 -> ICreateTypeInfo2 a0
+                 -> IO ()
+setParamCustData indexFunc indexParam guid1 pVarVal iptr =
+  do
+    guid1 <- marshallGUID guid1
+    pVarVal <- marshallVARIANT pVarVal
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr guid1 (\ guid1 -> prim_System_Win32_Com_Automation_TypeLib_setParamCustData methPtr iptr indexFunc indexParam guid1 pVarVal)) 33 iptr
+    free pVarVal
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_setParamCustData :: Ptr () -> Ptr () -> Word32 -> Word32 -> Ptr GUID -> VARIANT -> IO Int32
+setVarCustData :: UINT
+               -> REFGUID
+               -> VARIANT
+               -> ICreateTypeInfo2 a0
+               -> IO ()
+setVarCustData index guid1 pVarVal iptr =
+  do
+    guid1 <- marshallGUID guid1
+    pVarVal <- marshallVARIANT pVarVal
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr guid1 (\ guid1 -> prim_System_Win32_Com_Automation_TypeLib_setFuncCustData methPtr iptr index guid1 pVarVal)) 34 iptr
+    free pVarVal
+
+setImplTypeCustData :: UINT
+                    -> REFGUID
+                    -> VARIANT
+                    -> ICreateTypeInfo2 a0
+                    -> IO ()
+setImplTypeCustData index guid1 pVarVal iptr =
+  do
+    guid1 <- marshallGUID guid1
+    pVarVal <- marshallVARIANT pVarVal
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr guid1 (\ guid1 -> prim_System_Win32_Com_Automation_TypeLib_setFuncCustData methPtr iptr index guid1 pVarVal)) 35 iptr
+    free pVarVal
+
+setHelpStringContext :: ULONG
+                     -> ICreateTypeInfo2 a0
+                     -> IO ()
+setHelpStringContext dwHelpStringContext iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_setTypeFlags methPtr iptr dwHelpStringContext)
+                 36
+                 iptr
+
+setFuncHelpStringContext :: UINT
+                         -> ULONG
+                         -> ICreateTypeInfo2 a0
+                         -> IO ()
+setFuncHelpStringContext index dwHelpStringContext iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_addImplType methPtr iptr index dwHelpStringContext)
+                 37
+                 iptr
+
+setVarHelpStringContext :: UINT
+                        -> ULONG
+                        -> ICreateTypeInfo2 a0
+                        -> IO ()
+setVarHelpStringContext index dwHelpStringContext iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_addImplType methPtr iptr index dwHelpStringContext)
+                 38
+                 iptr
+
+invalidate :: ICreateTypeInfo2 a0
+           -> IO ()
+invalidate iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_layOut methPtr iptr)
+                 39
+                 iptr
+
+setName :: LPOLESTR
+        -> ICreateTypeInfo2 a0
+        -> IO ()
+setName szName iptr =
+  do
+    szName <- marshallWideString szName
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_setDocString methPtr iptr szName) 40 iptr
+    freeWideString szName
+
+-- --------------------------------------------------
+-- 
+-- interface ICreateTypeLib
+-- 
+-- --------------------------------------------------
+data ICreateTypeLib_ a = ICreateTypeLib__
+                           
+type ICreateTypeLib a = IUnknown (ICreateTypeLib_ a)
+iidICreateTypeLib :: IID (ICreateTypeLib ())
+iidICreateTypeLib = mkIID "{00020406-0000-0000-C000-000000000046}"
+
+type LPCREATETYPELIB = Maybe (ICreateTypeLib ())
+createTypeInfo :: LPOLESTR
+               -> TYPEKIND
+               -> ICreateTypeLib a0
+               -> IO (ICreateTypeInfo ())
+createTypeInfo szName tkind iptr =
+  do
+    ppCTInfo <- allocBytes (fromIntegral sizeofForeignPtr)
+    szName <- marshallWideString szName
+    tkind <- marshallEnum32 tkind
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_createTypeInfo methPtr iptr szName tkind ppCTInfo) 3 iptr
+    freeWideString szName
+    doThenFree free (readIUnknown False) ppCTInfo
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_createTypeInfo :: Ptr () -> Ptr () -> Ptr WideString -> Int32 -> Ptr (Ptr (ICreateTypeInfo a)) -> IO Int32
+setNameCTL :: LPOLESTR
+           -> ICreateTypeLib a0
+           -> IO ()
+setNameCTL szName iptr =
+  do
+    szName <- marshallWideString szName
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_setDocString methPtr iptr szName) 4 iptr
+    freeWideString szName
+
+setVersionCTL :: WORD
+              -> WORD
+              -> ICreateTypeLib a0
+              -> IO ()
+setVersionCTL wMajorVerNum0 wMinorVerNum0 iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_setVersion methPtr iptr wMajorVerNum0 wMinorVerNum0)
+                 5
+                 iptr
+
+setGuidCTL :: REFGUID
+           -> ICreateTypeLib a0
+           -> IO ()
+setGuidCTL guid1 iptr =
+  do
+    guid1 <- marshallGUID guid1
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr guid1 (\ guid1 -> prim_System_Win32_Com_Automation_TypeLib_setGuid methPtr iptr guid1)) 6 iptr
+
+setDocStringCTL :: LPOLESTR
+                -> ICreateTypeLib a0
+                -> IO ()
+setDocStringCTL szDoc iptr =
+  do
+    szDoc <- marshallWideString szDoc
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_setDocString methPtr iptr szDoc) 7 iptr
+    freeWideString szDoc
+
+setHelpFileName :: LPOLESTR
+                -> ICreateTypeLib a0
+                -> IO ()
+setHelpFileName szHelpFileName iptr =
+  do
+    szHelpFileName <- marshallWideString szHelpFileName
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_setDocString methPtr iptr szHelpFileName) 8 iptr
+    freeWideString szHelpFileName
+
+setHelpContextCTL :: DWORD
+                  -> ICreateTypeLib a0
+                  -> IO ()
+setHelpContextCTL dwHelpContext0 iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_setTypeFlags methPtr iptr dwHelpContext0)
+                 9
+                 iptr
+
+setLcid :: LCID
+        -> ICreateTypeLib a0
+        -> IO ()
+setLcid lcid0 iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_setTypeFlags methPtr iptr lcid0)
+                 10
+                 iptr
+
+setLibFlags :: UINT
+            -> ICreateTypeLib a0
+            -> IO ()
+setLibFlags uLibFlags iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_setTypeFlags methPtr iptr uLibFlags)
+                 11
+                 iptr
+
+saveAllChanges :: ICreateTypeLib a0
+               -> IO ()
+saveAllChanges iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_layOut methPtr iptr)
+                 12
+                 iptr
+
+-- --------------------------------------------------
+-- 
+-- interface ICreateTypeLib2
+-- 
+-- --------------------------------------------------
+data ICreateTypeLib2_ a = ICreateTypeLib2__
+                            
+type ICreateTypeLib2 a = ICreateTypeLib (ICreateTypeLib2_ a)
+iidICreateTypeLib2 :: IID (ICreateTypeLib2 ())
+iidICreateTypeLib2 = mkIID "{0002040F-0000-0000-C000-000000000046}"
+
+type LPCREATETYPELIB2 = Maybe (ICreateTypeLib2 ())
+deleteTypeInfo :: LPOLESTR
+               -> ICreateTypeLib2 a0
+               -> IO ()
+deleteTypeInfo szName iptr =
+  do
+    szName <- marshallWideString szName
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_setDocString methPtr iptr szName) 13 iptr
+    freeWideString szName
+
+setCustDataCTL :: REFGUID
+               -> VARIANT
+               -> ICreateTypeLib2 a0
+               -> IO ()
+setCustDataCTL guid1 pVarVal iptr =
+  do
+    guid1 <- marshallGUID guid1
+    pVarVal <- marshallVARIANT pVarVal
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr guid1 (\ guid1 -> prim_System_Win32_Com_Automation_TypeLib_setCustData methPtr iptr guid1 pVarVal)) 14 iptr
+    free pVarVal
+
+setHelpStringContextCTL :: ULONG
+                        -> ICreateTypeLib2 a0
+                        -> IO ()
+setHelpStringContextCTL dwHelpStringContext iptr =
+  invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_setTypeFlags methPtr iptr dwHelpStringContext)
+                 15
+                 iptr
+
+setHelpStringDll :: LPOLESTR
+                 -> ICreateTypeLib2 a0
+                 -> IO ()
+setHelpStringDll szFileName iptr =
+  do
+    szFileName <- marshallWideString szFileName
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_setDocString methPtr iptr szFileName) 16 iptr
+    freeWideString szFileName
+
+{- BEGIN_C_CODE
+/* DISPID reserved to indicate an "unknown" name */
+END_C_CODE-}
+{- BEGIN_C_CODE
+/* only reserved for data members (properties); reused as a method dispid below */
+END_C_CODE-}
+dISPID_UNKNOWN :: DISPID
+dISPID_UNKNOWN = (negate 1)
+
+{- BEGIN_C_CODE
+/* DISPID reserved for the "value" property */
+END_C_CODE-}
+dISPID_VALUE :: DISPID
+dISPID_VALUE = 0
+
+{- BEGIN_C_CODE
+/* The following DISPID is reserved to indicate the param
+END_C_CODE-}
+{- BEGIN_C_CODE
+ * that is the right-hand-side (or "put" value) of a PropertyPut
+END_C_CODE-}
+{- BEGIN_C_CODE
+ */
+END_C_CODE-}
+dISPID_PROPERTYPUT :: DISPID
+dISPID_PROPERTYPUT = (negate 3)
+
+{- BEGIN_C_CODE
+/* DISPID reserved for the standard "NewEnum" method */
+END_C_CODE-}
+dISPID_NEWENUM :: DISPID
+dISPID_NEWENUM = (negate 4)
+
+{- BEGIN_C_CODE
+/* DISPID reserved for the standard "Evaluate" method */
+END_C_CODE-}
+dISPID_EVALUATE :: DISPID
+dISPID_EVALUATE = (negate 5)
+
+dISPID_CONSTRUCTOR :: DISPID
+dISPID_CONSTRUCTOR = (negate 6)
+
+dISPID_DESTRUCTOR :: DISPID
+dISPID_DESTRUCTOR = (negate 7)
+
+dISPID_COLLECT :: DISPID
+dISPID_COLLECT = (negate 8)
+
+-- --------------------------------------------------
+-- 
+-- interface ITypeComp
+-- 
+-- --------------------------------------------------
+data ITypeComp_ a = ITypeComp__
+                      
+type ITypeComp a = IUnknown (ITypeComp_ a)
+iidITypeComp :: IID (ITypeComp ())
+iidITypeComp = mkIID "{00020403-0000-0000-C000-000000000046}"
+
+type LPTYPECOMP = Maybe (ITypeComp ())
+data DESCKIND
+ = DESCKIND_NONE
+ | DESCKIND_FUNCDESC
+ | DESCKIND_VARDESC
+ | DESCKIND_TYPECOMP
+ | DESCKIND_IMPLICITAPPOBJ
+ | DESCKIND_MAX
+ deriving (Enum)
+data BINDPTR
+ = Lpfuncdesc (Maybe FUNCDESC)
+ | Lpvardesc (Maybe VARDESC)
+ | Lptcomp (ITypeComp ())
+ 
+marshallBINDPTR :: BINDPTR
+                -> IO (BINDPTR, Int32)
+marshallBINDPTR = marshallUnion "marshallBINDPTR"
+
+unmarshallBINDPTR :: BINDPTR
+                  -> Int32
+                  -> IO BINDPTR
+unmarshallBINDPTR = unmarshallUnion "unmarshallBINDPTR"
+
+writeBINDPTR :: Bool
+             -> (Int32 -> IO ())
+             -> Ptr BINDPTR
+             -> BINDPTR
+             -> IO ()
+writeBINDPTR addRefMe__ write_tag ptr v =
+  case v of
+     (Lpfuncdesc lpfuncdesc) -> do
+                                  write_tag (-1)
+                                  writeunique (allocBytes (fromIntegral sizeofFUNCDESC)) writeFUNCDESC (castPtr ptr) lpfuncdesc
+     (Lpvardesc lpvardesc) -> do
+                                write_tag (-1)
+                                writeunique (allocBytes (fromIntegral sizeofVARDESC)) writeVARDESC (castPtr ptr) lpvardesc
+     (Lptcomp lptcomp) -> do
+                            write_tag (-1)
+                            writeIUnknown addRefMe__ (castPtr ptr) lptcomp
+
+readBINDPTR :: Bool
+            -> IO Int32
+            -> Ptr BINDPTR
+            -> IO BINDPTR
+readBINDPTR finaliseMe__ read_tag ptr =
+  error "readBINDPTR: I am the walrus."
+
+sizeofBINDPTR :: Word32
+sizeofBINDPTR = 4
+
+freeBINDPTR :: Int32
+            -> Ptr BINDPTR
+            -> IO ()
+freeBINDPTR read_tag ptr = error "freeBINDPTR: I am the walrus."
+
+type LPBINDPTR = BINDPTR
+bind :: LPOLESTR
+     -> ULONG
+     -> WORD
+     -> ITypeComp a0
+     -> IO (ITypeInfo (), DESCKIND, BINDPTR)
+bind szName lHashVal wFlags iptr =
+  do
+    ppTInfo <- allocBytes (fromIntegral sizeofForeignPtr)
+    pDescKind <- allocBytes (fromIntegral sizeofInt32)
+    pBindPtr <- allocBytes (fromIntegral sizeofBINDPTR)
+    szName <- marshallWideString szName
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_bind methPtr iptr szName lHashVal wFlags ppTInfo pDescKind pBindPtr) 3 iptr
+    freeWideString szName
+    ppTInfo <- doThenFree free (readIUnknown False) ppTInfo
+    pDescKind <- doThenFree free readEnum32 pDescKind
+    pBindPtr <- doThenFree free (readBINDPTR False (return ((-1)))) pBindPtr
+    return (ppTInfo, pDescKind, pBindPtr)
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_bind :: Ptr () -> Ptr () -> Ptr WideString -> Word32 -> Word16 -> Ptr (Ptr (ITypeInfo a)) -> Ptr DESCKIND -> Ptr BINDPTR -> IO Int32
+bindType :: LPOLESTR
+         -> ULONG
+         -> ITypeComp a0
+         -> IO (ITypeInfo (), ITypeComp ())
+bindType szName lHashVal iptr =
+  do
+    ppTInfo <- allocBytes (fromIntegral sizeofForeignPtr)
+    ppTComp <- allocBytes (fromIntegral sizeofForeignPtr)
+    szName <- marshallWideString szName
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_bindType methPtr iptr szName lHashVal ppTInfo ppTComp) 4 iptr
+    freeWideString szName
+    ppTInfo <- doThenFree free (readIUnknown False) ppTInfo
+    ppTComp <- doThenFree free (readIUnknown False) ppTComp
+    return (ppTInfo, ppTComp)
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_bindType :: Ptr () -> Ptr () -> Ptr WideString -> Word32 -> Ptr (Ptr (ITypeInfo a)) -> Ptr (Ptr (ITypeComp a)) -> IO Int32
+-- --------------------------------------------------
+-- 
+-- interface ITypeInfo
+-- 
+-- --------------------------------------------------
+data ITypeInfo_ a = ITypeInfo__
+                      
+type ITypeInfo a = IUnknown (ITypeInfo_ a)
+iidITypeInfo :: IID (ITypeInfo ())
+iidITypeInfo = mkIID "{00020401-0000-0000-C000-000000000046}"
+
+type LPTYPEINFO = Maybe (ITypeInfo ())
+getTypeAttr :: ITypeInfo a0
+            -> IO (Maybe TYPEATTR)
+getTypeAttr iptr =
+  do
+    ppTypeAttr <- allocBytes (fromIntegral sizeofPtr)
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_getTypeAttr methPtr iptr ppTypeAttr) 3 iptr
+    doThenFree free (readunique (readTYPEATTR False)) ppTypeAttr
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_getTypeAttr :: Ptr () -> Ptr () -> Ptr (Ptr TYPEATTR) -> IO Int32
+getTypeComp :: ITypeInfo a0
+            -> IO (ITypeComp ())
+getTypeComp iptr =
+  do
+    ppTComp <- allocBytes (fromIntegral sizeofForeignPtr)
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_getTypeComp methPtr iptr ppTComp) 4 iptr
+    doThenFree free (readIUnknown False) ppTComp
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_getTypeComp :: Ptr () -> Ptr () -> Ptr (Ptr (ITypeComp a)) -> IO Int32
+getFuncDesc :: UINT
+            -> ITypeInfo a0
+            -> IO (Maybe FUNCDESC)
+getFuncDesc index iptr =
+  do
+    ppFuncDesc <- allocBytes (fromIntegral sizeofPtr)
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_getFuncDesc methPtr iptr index ppFuncDesc) 5 iptr
+    doThenFree free (readunique readFUNCDESC) ppFuncDesc
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_getFuncDesc :: Ptr () -> Ptr () -> Word32 -> Ptr (Ptr FUNCDESC) -> IO Int32
+getVarDesc :: UINT
+           -> ITypeInfo a0
+           -> IO (Maybe VARDESC)
+getVarDesc index iptr =
+  do
+    ppVarDesc <- allocBytes (fromIntegral sizeofPtr)
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_getVarDesc methPtr iptr index ppVarDesc) 6 iptr
+    doThenFree free (readunique readVARDESC) ppVarDesc
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_getVarDesc :: Ptr () -> Ptr () -> Word32 -> Ptr (Ptr VARDESC) -> IO Int32
+getNames :: MEMBERID
+         -> UINT
+         -> ITypeInfo a0
+         -> IO [String]
+getNames memid1 cMaxNames iptr =
+  do
+    rgBstrNames <- allocBytes ((fromIntegral sizeofPtr * fromIntegral cMaxNames))
+    pcNames <- allocBytes (fromIntegral sizeofWord32)
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_getNames methPtr iptr memid1 rgBstrNames cMaxNames pcNames) 7 iptr
+    cMaxNames <- unmarshallWord32 cMaxNames
+    pcNames <- readWord32 pcNames
+    let pcNames' = (pcNames)
+    doThenFree free (unmarshalllist sizeofPtr 0 ((fromIntegral ((pcNames')) :: Word32)) readBSTR) rgBstrNames
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_getNames :: Ptr () -> Ptr () -> Int32 -> Ptr String -> Word32 -> Ptr Word32 -> IO Int32
+getRefTypeOfImplType :: UINT
+                     -> ITypeInfo a0
+                     -> IO HREFTYPE
+getRefTypeOfImplType index iptr =
+  do
+    pRefType <- allocBytes (fromIntegral sizeofWord32)
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_getRefTypeOfImplType methPtr iptr index pRefType) 8 iptr
+    doThenFree free readWord32 pRefType
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_getRefTypeOfImplType :: Ptr () -> Ptr () -> Word32 -> Ptr Word32 -> IO Int32
+getImplTypeFlags :: UINT
+                 -> ITypeInfo a0
+                 -> IO INT
+getImplTypeFlags index iptr =
+  do
+    pImplTypeFlags <- allocBytes (fromIntegral sizeofInt32)
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_getImplTypeFlags methPtr iptr index pImplTypeFlags) 9 iptr
+    doThenFree free readInt32 pImplTypeFlags
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_getImplTypeFlags :: Ptr () -> Ptr () -> Word32 -> Ptr Int32 -> IO Int32
+getIDsOfNames :: [LPOLESTR]
+              -> ITypeInfo a0
+              -> IO [MEMBERID]
+getIDsOfNames rgszNames iptr =
+  let
+   cNames = (fromIntegral (length rgszNames) :: Word32)
+  in
+  do
+    rgszNames <- marshalllist sizeofPtr writeWideString rgszNames
+    pMemId <- allocBytes ((fromIntegral sizeofInt32 * fromIntegral cNames))
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_getIDsOfNames methPtr iptr rgszNames cNames pMemId) 10 iptr
+    free rgszNames
+    cNames <- unmarshallWord32 cNames
+    doThenFree (freeref trivialFree) (unmarshalllist sizeofInt32 0 ((fromIntegral cNames :: Word32)) readInt32) pMemId
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_getIDsOfNames :: Ptr () -> Ptr () -> Ptr (Ptr WideString) -> Word32 -> Ptr Int32 -> IO Int32
+invoke :: PVOID
+       -> MEMBERID
+       -> WORD
+       -> DISPPARAMS
+       -> ITypeInfo a0
+       -> IO (DISPPARAMS, VARIANT, EXCEPINFO, UINT)
+invoke pvInstance memid1 wFlags pDispParams iptr =
+  do
+    pVarResult <- allocVARIANT
+    pExcepInfo <- allocBytes (fromIntegral sizeofEXCEPINFO)
+    puArgErr <- allocBytes (fromIntegral sizeofWord32)
+    pDispParams <- marshallref (allocBytes (fromIntegral sizeofDISPPARAMS)) writeDISPPARAMS pDispParams
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_invoke methPtr iptr pvInstance memid1 wFlags pDispParams pVarResult pExcepInfo puArgErr) 11 iptr
+    pVarResult <- unmarshallVARIANT pVarResult
+    pExcepInfo <- doThenFree free readEXCEPINFO pExcepInfo
+    puArgErr <- doThenFree free readWord32 puArgErr
+    pDispParams <- doThenFree free readDISPPARAMS pDispParams
+    return (pDispParams, pVarResult, pExcepInfo, puArgErr)
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_invoke :: Ptr () -> Ptr () -> Ptr () -> Int32 -> Word16 -> Ptr DISPPARAMS -> VARIANT -> Ptr EXCEPINFO -> Ptr Word32 -> IO Int32
+getDocumentation :: MEMBERID
+                 -> ITypeInfo a0
+                 -> IO (String, String, DWORD, String)
+getDocumentation memid1 iptr =
+  do
+    pBstrName <- allocBytes (fromIntegral sizeofPtr)
+    pBstrDocString <- allocBytes (fromIntegral sizeofPtr)
+    pdwHelpContext <- allocBytes (fromIntegral sizeofWord32)
+    pBstrHelpFile <- allocBytes (fromIntegral sizeofPtr)
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_getDocumentation methPtr iptr memid1 pBstrName pBstrDocString pdwHelpContext pBstrHelpFile) 12 iptr
+    pBstrName <- doThenFree (freeref freeBSTR) readBSTR pBstrName
+    pBstrDocString <- doThenFree (freeref freeBSTR) readBSTR pBstrDocString
+    pdwHelpContext <- doThenFree free readWord32 pdwHelpContext
+    pBstrHelpFile <- doThenFree (freeref freeBSTR) readBSTR pBstrHelpFile
+    return (pBstrName, pBstrDocString, pdwHelpContext, pBstrHelpFile)
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_getDocumentation :: Ptr () -> Ptr () -> Int32 -> Ptr String -> Ptr String -> Ptr Word32 -> Ptr String -> IO Int32
+getDllEntry :: MEMBERID
+            -> INVOKEKIND
+            -> ITypeInfo a0
+            -> IO (String, String, WORD)
+getDllEntry memid1 invKind iptr =
+  do
+    pBstrDllName <- allocBytes (fromIntegral sizeofPtr)
+    pBstrName <- allocBytes (fromIntegral sizeofPtr)
+    pwOrdinal <- allocBytes (fromIntegral sizeofWord16)
+    invKind <- marshallEnum32 invKind
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_getDllEntry methPtr iptr memid1 invKind pBstrDllName pBstrName pwOrdinal) 13 iptr
+    pBstrDllName <- doThenFree (freeref freeBSTR) readBSTR pBstrDllName
+    pBstrName <- doThenFree (freeref freeBSTR) readBSTR pBstrName
+    pwOrdinal <- doThenFree free readWord16 pwOrdinal
+    return (pBstrDllName, pBstrName, pwOrdinal)
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_getDllEntry :: Ptr () -> Ptr () -> Int32 -> Int32 -> Ptr String -> Ptr String -> Ptr Word16 -> IO Int32
+getRefTypeInfo :: HREFTYPE
+               -> ITypeInfo a0
+               -> IO (ITypeInfo ())
+getRefTypeInfo hRefType iptr =
+  do
+    ppTInfo <- allocBytes (fromIntegral sizeofForeignPtr)
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_getRefTypeInfo methPtr iptr hRefType ppTInfo) 14 iptr
+    doThenFree free (readIUnknown False) ppTInfo
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_getRefTypeInfo :: Ptr () -> Ptr () -> Word32 -> Ptr (Ptr (ITypeInfo a)) -> IO Int32
+addressOfMember :: MEMBERID
+                -> INVOKEKIND
+                -> ITypeInfo a0
+                -> IO PVOID
+addressOfMember memid1 invKind iptr =
+  do
+    ppv <- allocBytes (fromIntegral sizeofPtr)
+    invKind <- marshallEnum32 invKind
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_addressOfMember methPtr iptr memid1 invKind ppv) 15 iptr
+    doThenFree free readPtr ppv
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_addressOfMember :: Ptr () -> Ptr () -> Int32 -> Int32 -> Ptr (Ptr ()) -> IO Int32
+createInstance :: IUnknown a2
+               -> IID a3
+               -> ITypeInfo a0
+               -> IO (IUnknown a1)
+createInstance pUnkOuter riid iptr =
+  do
+    ppvObj <- allocBytes (fromIntegral sizeofForeignPtr)
+    pUnkOuter <- marshallIUnknown pUnkOuter
+    riid <- marshallIID riid
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr pUnkOuter (\ pUnkOuter -> withForeignPtr riid (\ riid -> prim_System_Win32_Com_Automation_TypeLib_createInstance methPtr iptr pUnkOuter riid ppvObj))) 16 iptr
+    doThenFree free (readIUnknown False) ppvObj
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_createInstance :: Ptr () -> Ptr () -> Ptr (IUnknown a) -> Ptr (IID a) -> Ptr (Ptr (IUnknown a)) -> IO Int32
+getMops :: MEMBERID
+        -> ITypeInfo a0
+        -> IO String
+getMops memid1 iptr =
+  do
+    pBstrMops <- allocBytes (fromIntegral sizeofPtr)
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_getMops methPtr iptr memid1 pBstrMops) 17 iptr
+    doThenFree (freeref freeBSTR) readBSTR pBstrMops
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_getMops :: Ptr () -> Ptr () -> Int32 -> Ptr String -> IO Int32
+getContainingTypeLib :: ITypeInfo a0
+                     -> IO (ITypeLib (), UINT)
+getContainingTypeLib iptr =
+  do
+    ppTLib <- allocBytes (fromIntegral sizeofForeignPtr)
+    pIndex <- allocBytes (fromIntegral sizeofWord32)
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_getContainingTypeLib methPtr iptr ppTLib pIndex) 18 iptr
+    ppTLib <- doThenFree free (readIUnknown False) ppTLib
+    pIndex <- doThenFree free readWord32 pIndex
+    return (ppTLib, pIndex)
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_getContainingTypeLib :: Ptr () -> Ptr () -> Ptr (Ptr (ITypeLib a)) -> Ptr Word32 -> IO Int32
+releaseTypeAttr :: Ptr TYPEATTR
+                -> ITypeInfo a0
+                -> IO ()
+releaseTypeAttr pTypeAttr iptr =
+  invokeIt (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_releaseTypeAttr methPtr iptr pTypeAttr)
+           19
+           iptr
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_releaseTypeAttr :: Ptr () -> Ptr () -> Ptr TYPEATTR -> IO ()
+releaseFuncDesc :: Ptr FUNCDESC
+                -> ITypeInfo a0
+                -> IO ()
+releaseFuncDesc pFuncDesc iptr =
+  invokeIt (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_releaseFuncDesc methPtr iptr pFuncDesc)
+           20
+           iptr
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_releaseFuncDesc :: Ptr () -> Ptr () -> Ptr FUNCDESC -> IO ()
+releaseVarDesc :: Ptr VARDESC
+               -> ITypeInfo a0
+               -> IO ()
+releaseVarDesc pVarDesc iptr =
+  invokeIt (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_releaseVarDesc methPtr iptr pVarDesc)
+           21
+           iptr
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_releaseVarDesc :: Ptr () -> Ptr () -> Ptr VARDESC -> IO ()
+-- --------------------------------------------------
+-- 
+-- interface ITypeInfo2
+-- 
+-- --------------------------------------------------
+data ITypeInfo2_ a = ITypeInfo2__
+                       
+type ITypeInfo2 a = ITypeInfo (ITypeInfo2_ a)
+iidITypeInfo2 :: IID (ITypeInfo2 ())
+iidITypeInfo2 = mkIID "{00020412-0000-0000-C000-000000000046}"
+
+type LPTYPEINFO2 = Maybe (ITypeInfo2 ())
+getTypeKind :: ITypeInfo2 a0
+            -> IO TYPEKIND
+getTypeKind iptr =
+  do
+    pTypeKind <- allocBytes (fromIntegral sizeofInt32)
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_getTypeKind methPtr iptr pTypeKind) 22 iptr
+    doThenFree free readEnum32 pTypeKind
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_getTypeKind :: Ptr () -> Ptr () -> Ptr TYPEKIND -> IO Int32
+getTypeFlags :: ITypeInfo2 a0
+             -> IO ULONG
+getTypeFlags iptr =
+  do
+    pTypeFlags <- allocBytes (fromIntegral sizeofWord32)
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_getTypeFlags methPtr iptr pTypeFlags) 23 iptr
+    doThenFree free readWord32 pTypeFlags
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_getTypeFlags :: Ptr () -> Ptr () -> Ptr Word32 -> IO Int32
+getFuncIndexOfMemId :: MEMBERID
+                    -> INVOKEKIND
+                    -> ITypeInfo2 a0
+                    -> IO UINT
+getFuncIndexOfMemId memid1 invKind iptr =
+  do
+    pFuncIndex <- allocBytes (fromIntegral sizeofWord32)
+    invKind <- marshallEnum32 invKind
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_getFuncIndexOfMemId methPtr iptr memid1 invKind pFuncIndex) 24 iptr
+    doThenFree free readWord32 pFuncIndex
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_getFuncIndexOfMemId :: Ptr () -> Ptr () -> Int32 -> Int32 -> Ptr Word32 -> IO Int32
+getVarIndexOfMemId :: MEMBERID
+                   -> ITypeInfo2 a0
+                   -> IO UINT
+getVarIndexOfMemId memid1 iptr =
+  do
+    pVarIndex <- allocBytes (fromIntegral sizeofWord32)
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_getVarIndexOfMemId methPtr iptr memid1 pVarIndex) 25 iptr
+    doThenFree free readWord32 pVarIndex
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_getVarIndexOfMemId :: Ptr () -> Ptr () -> Int32 -> Ptr Word32 -> IO Int32
+getCustData :: REFGUID
+            -> ITypeInfo2 a0
+            -> IO VARIANT
+getCustData guid1 iptr =
+  do
+    pVarVal <- allocVARIANT
+    guid1 <- marshallGUID guid1
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr guid1 (\ guid1 -> prim_System_Win32_Com_Automation_TypeLib_setCustData methPtr iptr guid1 pVarVal)) 26 iptr
+    unmarshallVARIANT pVarVal
+
+getFuncCustData :: UINT
+                -> REFGUID
+                -> ITypeInfo2 a0
+                -> IO VARIANT
+getFuncCustData index guid1 iptr =
+  do
+    pVarVal <- allocVARIANT
+    guid1 <- marshallGUID guid1
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr guid1 (\ guid1 -> prim_System_Win32_Com_Automation_TypeLib_setFuncCustData methPtr iptr index guid1 pVarVal)) 27 iptr
+    unmarshallVARIANT pVarVal
+
+getParamCustData :: UINT
+                 -> UINT
+                 -> REFGUID
+                 -> ITypeInfo2 a0
+                 -> IO VARIANT
+getParamCustData indexFunc indexParam guid1 iptr =
+  do
+    pVarVal <- allocVARIANT
+    guid1 <- marshallGUID guid1
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr guid1 (\ guid1 -> prim_System_Win32_Com_Automation_TypeLib_setParamCustData methPtr iptr indexFunc indexParam guid1 pVarVal)) 28 iptr
+    unmarshallVARIANT pVarVal
+
+getVarCustData :: UINT
+               -> REFGUID
+               -> ITypeInfo2 a0
+               -> IO VARIANT
+getVarCustData index guid1 iptr =
+  do
+    pVarVal <- allocVARIANT
+    guid1 <- marshallGUID guid1
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr guid1 (\ guid1 -> prim_System_Win32_Com_Automation_TypeLib_setFuncCustData methPtr iptr index guid1 pVarVal)) 29 iptr
+    unmarshallVARIANT pVarVal
+
+getImplTypeCustData :: UINT
+                    -> REFGUID
+                    -> ITypeInfo2 a0
+                    -> IO VARIANT
+getImplTypeCustData index guid1 iptr =
+  do
+    pVarVal <- allocVARIANT
+    guid1 <- marshallGUID guid1
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr guid1 (\ guid1 -> prim_System_Win32_Com_Automation_TypeLib_setFuncCustData methPtr iptr index guid1 pVarVal)) 30 iptr
+    unmarshallVARIANT pVarVal
+
+getDocumentation2 :: MEMBERID
+                  -> LCID
+                  -> ITypeInfo2 a0
+                  -> IO (String, DWORD, String)
+getDocumentation2 memid1 lcid0 iptr =
+  do
+    pbstrHelpString <- allocBytes (fromIntegral sizeofPtr)
+    pdwHelpStringContext <- allocBytes (fromIntegral sizeofWord32)
+    pbstrHelpStringDll <- allocBytes (fromIntegral sizeofPtr)
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_getDocumentation2 methPtr iptr memid1 lcid0 pbstrHelpString pdwHelpStringContext pbstrHelpStringDll) 31 iptr
+    pbstrHelpString <- doThenFree (freeref freeBSTR) readBSTR pbstrHelpString
+    pdwHelpStringContext <- doThenFree free readWord32 pdwHelpStringContext
+    pbstrHelpStringDll <- doThenFree (freeref freeBSTR) readBSTR pbstrHelpStringDll
+    return (pbstrHelpString, pdwHelpStringContext, pbstrHelpStringDll)
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_getDocumentation2 :: Ptr () -> Ptr () -> Int32 -> Word32 -> Ptr String -> Ptr Word32 -> Ptr String -> IO Int32
+getAllCustData :: ITypeInfo2 a0
+               -> IO CUSTDATA
+getAllCustData iptr =
+  do
+    pCustData <- allocBytes (fromIntegral sizeofCUSTDATA)
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_getAllCustData methPtr iptr pCustData) 32 iptr
+    doThenFree free (readCUSTDATA False) pCustData
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_getAllCustData :: Ptr () -> Ptr () -> Ptr CUSTDATA -> IO Int32
+getAllFuncCustData :: UINT
+                   -> ITypeInfo2 a0
+                   -> IO CUSTDATA
+getAllFuncCustData index iptr =
+  do
+    pCustData <- allocBytes (fromIntegral sizeofCUSTDATA)
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_getAllFuncCustData methPtr iptr index pCustData) 33 iptr
+    doThenFree free (readCUSTDATA False) pCustData
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_getAllFuncCustData :: Ptr () -> Ptr () -> Word32 -> Ptr CUSTDATA -> IO Int32
+getAllParamCustData :: UINT
+                    -> UINT
+                    -> ITypeInfo2 a0
+                    -> IO CUSTDATA
+getAllParamCustData indexFunc indexParam iptr =
+  do
+    pCustData <- allocBytes (fromIntegral sizeofCUSTDATA)
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_getAllParamCustData methPtr iptr indexFunc indexParam pCustData) 34 iptr
+    doThenFree free (readCUSTDATA False) pCustData
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_getAllParamCustData :: Ptr () -> Ptr () -> Word32 -> Word32 -> Ptr CUSTDATA -> IO Int32
+getAllVarCustData :: UINT
+                  -> ITypeInfo2 a0
+                  -> IO CUSTDATA
+getAllVarCustData index iptr =
+  do
+    pCustData <- allocBytes (fromIntegral sizeofCUSTDATA)
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_getAllFuncCustData methPtr iptr index pCustData) 35 iptr
+    doThenFree free (readCUSTDATA False) pCustData
+
+getAllImplTypeCustData :: UINT
+                       -> ITypeInfo2 a0
+                       -> IO CUSTDATA
+getAllImplTypeCustData index iptr =
+  do
+    pCustData <- allocBytes (fromIntegral sizeofCUSTDATA)
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_getAllFuncCustData methPtr iptr index pCustData) 36 iptr
+    doThenFree free (readCUSTDATA False) pCustData
+
+-- --------------------------------------------------
+-- 
+-- interface ITypeLib
+-- 
+-- --------------------------------------------------
+data ITypeLib_ a = ITypeLib__
+                     
+type ITypeLib a = IUnknown (ITypeLib_ a)
+iidITypeLib :: IID (ITypeLib ())
+iidITypeLib = mkIID "{00020402-0000-0000-C000-000000000046}"
+
+data SYSKIND
+ = SYSKINDList__ [SYSKIND]
+ | SYS_WIN16
+ | SYS_WIN32
+ | SYS_MAC
+ 
+instance Flags (SYSKIND) where
+  x1 .+. x2
+    = toEnum ((fromEnum x1 + fromEnum x2))
+  
+instance Enum (SYSKIND) where
+  fromEnum v =
+    case v of
+       (SYSKINDList__ xs) -> orList (map fromEnum xs)
+       SYS_WIN16 -> 0
+       SYS_WIN32 -> 1
+       SYS_MAC -> 2
+  
+  toEnum v =
+    case v of
+       0 -> SYS_WIN16
+       1 -> SYS_WIN32
+       2 -> SYS_MAC
+       x -> SYSKINDList__ (mapMaybe (\ val -> if ((val .&. fromIntegral x) == val)
+                                                then Just (toEnum (fromIntegral val))
+                                                else Nothing) (pow2Series 3 0))
+       _ -> error "unmarshallSYSKIND: illegal enum value "
+  
+data LIBFLAGS
+ = LIBFLAGSList__ [LIBFLAGS]
+ | LIBFLAG_FRESTRICTED
+ | LIBFLAG_FCONTROL
+ | LIBFLAG_FHIDDEN
+ | LIBFLAG_FHASDISKIMAGE
+ 
+instance Flags (LIBFLAGS) where
+  x1 .+. x2
+    = toEnum ((fromEnum x1 + fromEnum x2))
+  
+instance Enum (LIBFLAGS) where
+  fromEnum v =
+    case v of
+       (LIBFLAGSList__ xs) -> orList (map fromEnum xs)
+       LIBFLAG_FRESTRICTED -> 1
+       LIBFLAG_FCONTROL -> 2
+       LIBFLAG_FHIDDEN -> 4
+       LIBFLAG_FHASDISKIMAGE -> 8
+  
+  toEnum v =
+    case v of
+       1 -> LIBFLAG_FRESTRICTED
+       2 -> LIBFLAG_FCONTROL
+       4 -> LIBFLAG_FHIDDEN
+       8 -> LIBFLAG_FHASDISKIMAGE
+       x -> LIBFLAGSList__ (mapMaybe (\ val -> if ((val .&. fromIntegral x) == val)
+                                                 then Just (toEnum (fromIntegral val))
+                                                 else Nothing) (pow2Series 4 1))
+       _ -> error "unmarshallLIBFLAGS: illegal enum value "
+  
+type LPTYPELIB = Maybe (ITypeLib ())
+data TLIBATTR = TagTLIBATTR {guid1 :: GUID,
+                             lcid0 :: LCID,
+                             syskind :: SYSKIND,
+                             wMajorVerNum0 :: WORD,
+                             wMinorVerNum0 :: WORD,
+                             wLibFlags :: WORD}
+                  
+writeTLIBATTR :: Ptr TLIBATTR
+              -> TLIBATTR
+              -> IO ()
+writeTLIBATTR ptr (TagTLIBATTR guid1 lcid0 syskind wMajorVerNum0 wMinorVerNum0 wLibFlags) =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    writeGUID pf1 guid1
+    let pf2 = addNCastPtr pf1 16
+    writeWord32 pf2 lcid0
+    let pf3 = addNCastPtr pf2 4
+    writeEnum32 pf3 syskind
+    let pf4 = addNCastPtr pf3 4
+    writeWord16 pf4 wMajorVerNum0
+    let pf5 = addNCastPtr pf4 2
+    writeWord16 pf5 wMinorVerNum0
+    let pf6 = addNCastPtr pf5 2
+    writeWord16 pf6 wLibFlags
+
+readTLIBATTR :: Bool
+             -> Ptr TLIBATTR
+             -> IO TLIBATTR
+readTLIBATTR finaliseMe__ ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    guid1 <- readGUID finaliseMe__ pf1
+    let pf2 = addNCastPtr pf1 16
+    lcid0 <- readWord32 pf2
+    let pf3 = addNCastPtr pf2 4
+    syskind <- readEnum32 pf3
+    let pf4 = addNCastPtr pf3 4
+    wMajorVerNum0 <- readWord16 pf4
+    let pf5 = addNCastPtr pf4 2
+    wMinorVerNum0 <- readWord16 pf5
+    let pf6 = addNCastPtr pf5 2
+    wLibFlags <- readWord16 pf6
+    return (TagTLIBATTR guid1 lcid0 syskind wMajorVerNum0 wMinorVerNum0 wLibFlags)
+
+sizeofTLIBATTR :: Word32
+sizeofTLIBATTR = 32
+
+type LPTLIBATTR = TLIBATTR
+getTypeInfoCount :: ITypeLib a0
+                 -> IO UINT
+getTypeInfoCount iptr =
+  invokeIt (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_getTypeInfoCount methPtr iptr)
+           3
+           iptr
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_getTypeInfoCount :: Ptr () -> Ptr () -> IO Word32
+getTypeInfo :: UINT
+            -> ITypeLib a0
+            -> IO (ITypeInfo ())
+getTypeInfo index iptr =
+  do
+    ppTInfo <- allocBytes (fromIntegral sizeofForeignPtr)
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_getRefTypeInfo methPtr iptr index ppTInfo) 4 iptr
+    doThenFree free (readIUnknown False) ppTInfo
+
+getTypeInfoType :: UINT
+                -> ITypeLib a0
+                -> IO TYPEKIND
+getTypeInfoType index iptr =
+  do
+    pTKind <- allocBytes (fromIntegral sizeofInt32)
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_getTypeInfoType methPtr iptr index pTKind) 5 iptr
+    doThenFree free readEnum32 pTKind
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_getTypeInfoType :: Ptr () -> Ptr () -> Word32 -> Ptr TYPEKIND -> IO Int32
+getTypeInfoOfGuid :: REFGUID
+                  -> ITypeLib a0
+                  -> IO (ITypeInfo ())
+getTypeInfoOfGuid guid2 iptr =
+  do
+    ppTinfo <- allocBytes (fromIntegral sizeofForeignPtr)
+    guid2 <- marshallGUID guid2
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr guid2 (\ guid2 -> prim_System_Win32_Com_Automation_TypeLib_getTypeInfoOfGuid methPtr iptr guid2 ppTinfo)) 6 iptr
+    doThenFree free (readIUnknown False) ppTinfo
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_getTypeInfoOfGuid :: Ptr () -> Ptr () -> Ptr GUID -> Ptr (Ptr (ITypeInfo a)) -> IO Int32
+getLibAttr :: ITypeLib a0
+           -> IO (Maybe TLIBATTR)
+getLibAttr iptr =
+  do
+    ppTLibAttr <- allocBytes (fromIntegral sizeofPtr)
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_getLibAttr methPtr iptr ppTLibAttr) 7 iptr
+    doThenFree free (readunique (readTLIBATTR False)) ppTLibAttr
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_getLibAttr :: Ptr () -> Ptr () -> Ptr (Ptr TLIBATTR) -> IO Int32
+getTypeCompTL :: ITypeLib a0
+              -> IO (ITypeComp ())
+getTypeCompTL iptr =
+  do
+    ppTComp <- allocBytes (fromIntegral sizeofForeignPtr)
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_getTypeComp methPtr iptr ppTComp) 8 iptr
+    doThenFree free (readIUnknown False) ppTComp
+
+getDocumentationTL :: INT
+                   -> ITypeLib a0
+                   -> IO (String, String, DWORD, String)
+getDocumentationTL index iptr =
+  do
+    pBstrName <- allocBytes (fromIntegral sizeofPtr)
+    pBstrDocString <- allocBytes (fromIntegral sizeofPtr)
+    pdwHelpContext <- allocBytes (fromIntegral sizeofWord32)
+    pBstrHelpFile <- allocBytes (fromIntegral sizeofPtr)
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_getDocumentation methPtr iptr index pBstrName pBstrDocString pdwHelpContext pBstrHelpFile) 9 iptr
+    pBstrName <- doThenFree (freeref freeBSTR) readBSTR pBstrName
+    pBstrDocString <- doThenFree (freeref freeBSTR) readBSTR pBstrDocString
+    pdwHelpContext <- doThenFree free readWord32 pdwHelpContext
+    pBstrHelpFile <- doThenFree (freeref freeBSTR) readBSTR pBstrHelpFile
+    return (pBstrName, pBstrDocString, pdwHelpContext, pBstrHelpFile)
+
+isName :: LPOLESTR
+       -> ULONG
+       -> ITypeLib a0
+       -> IO (LPOLESTR, BOOL)
+isName szNameBuf lHashVal iptr =
+  do
+    pfName <- allocBytes (fromIntegral sizeofInt32)
+    szNameBuf <- marshallWideString szNameBuf
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_isName methPtr iptr szNameBuf lHashVal pfName) 10 iptr
+    pfName <- doThenFree free readInt32 pfName
+    szNameBuf <- doThenFree freeWideString unmarshallWideString szNameBuf
+    return (szNameBuf, pfName)
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_isName :: Ptr () -> Ptr () -> Ptr WideString -> Word32 -> Ptr Int32 -> IO Int32
+findName :: LPOLESTR
+         -> ULONG
+         -> USHORT
+         -> ITypeLib a0
+         -> IO (LPOLESTR, [ITypeInfo ()], [MEMBERID])
+findName szNameBuf lHashVal pcFound iptr =
+  do
+    ppTInfo <- allocBytes ((fromIntegral sizeofForeignPtr * fromIntegral ((pcFound))))
+    rgMemId <- allocBytes ((fromIntegral sizeofInt32 * fromIntegral ((pcFound))))
+    szNameBuf <- marshallWideString szNameBuf
+    pcFound <- marshallref (allocBytes (fromIntegral sizeofWord16)) writeWord16 pcFound
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_findName methPtr iptr szNameBuf lHashVal ppTInfo rgMemId pcFound) 11 iptr
+    szNameBuf <- doThenFree freeWideString unmarshallWideString szNameBuf
+    pcFound <- readWord16 pcFound
+    let pcFound' = (pcFound)
+    ppTInfo <- doThenFree (freeref trivialFree) (unmarshalllist sizeofForeignPtr 0 ((fromIntegral ((pcFound')) :: Word32)) (readIUnknown False)) ppTInfo
+    rgMemId <- doThenFree (freeref trivialFree) (unmarshalllist sizeofInt32 0 ((fromIntegral ((pcFound')) :: Word32)) readInt32) rgMemId
+    return (szNameBuf, ppTInfo, rgMemId)
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_findName :: Ptr () -> Ptr () -> Ptr WideString -> Word32 -> Ptr (Ptr (ITypeInfo a)) -> Ptr Int32 -> Ptr Word16 -> IO Int32
+releaseTLibAttr :: Ptr TLIBATTR
+                -> ITypeLib a0
+                -> IO ()
+releaseTLibAttr pTLibAttr iptr =
+  invokeIt (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_releaseTLibAttr methPtr iptr pTLibAttr)
+           12
+           iptr
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_releaseTLibAttr :: Ptr () -> Ptr () -> Ptr TLIBATTR -> IO ()
+-- --------------------------------------------------
+-- 
+-- interface ITypeLib2
+-- 
+-- --------------------------------------------------
+data ITypeLib2_ a = ITypeLib2__
+                      
+type ITypeLib2 a = ITypeLib (ITypeLib2_ a)
+iidITypeLib2 :: IID (ITypeLib2 ())
+iidITypeLib2 = mkIID "{00020411-0000-0000-C000-000000000046}"
+
+type LPTYPELIB2 = Maybe (ITypeLib2 ())
+getCustDataTL :: GUID
+              -> ITypeLib2 a0
+              -> IO VARIANT
+getCustDataTL guid2 iptr =
+  do
+    pVarVal <- allocVARIANT
+    guid2 <- marshallGUID guid2
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr guid2 (\ guid2 -> prim_System_Win32_Com_Automation_TypeLib_setCustData methPtr iptr guid2 pVarVal)) 13 iptr
+    unmarshallVARIANT pVarVal
+
+getLibStatistics :: ITypeLib2 a0
+                 -> IO (ULONG, ULONG)
+getLibStatistics iptr =
+  do
+    pcUniqueNames <- allocBytes (fromIntegral sizeofWord32)
+    pcchUniqueNames <- allocBytes (fromIntegral sizeofWord32)
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_getLibStatistics methPtr iptr pcUniqueNames pcchUniqueNames) 14 iptr
+    pcUniqueNames <- doThenFree free readWord32 pcUniqueNames
+    pcchUniqueNames <- doThenFree free readWord32 pcchUniqueNames
+    return (pcUniqueNames, pcchUniqueNames)
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_getLibStatistics :: Ptr () -> Ptr () -> Ptr Word32 -> Ptr Word32 -> IO Int32
+getDocumentation2TL :: INT
+                    -> LCID
+                    -> ITypeLib2 a0
+                    -> IO (String, DWORD, String)
+getDocumentation2TL index lcid1 iptr =
+  do
+    pbstrHelpString <- allocBytes (fromIntegral sizeofPtr)
+    pdwHelpStringContext <- allocBytes (fromIntegral sizeofWord32)
+    pbstrHelpStringDll <- allocBytes (fromIntegral sizeofPtr)
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_getDocumentation2 methPtr iptr index lcid1 pbstrHelpString pdwHelpStringContext pbstrHelpStringDll) 15 iptr
+    pbstrHelpString <- doThenFree (freeref freeBSTR) readBSTR pbstrHelpString
+    pdwHelpStringContext <- doThenFree free readWord32 pdwHelpStringContext
+    pbstrHelpStringDll <- doThenFree (freeref freeBSTR) readBSTR pbstrHelpStringDll
+    return (pbstrHelpString, pdwHelpStringContext, pbstrHelpStringDll)
+
+getAllCustDataTL :: ITypeLib2 a0
+                 -> IO CUSTDATA
+getAllCustDataTL iptr =
+  do
+    pCustData <- allocBytes (fromIntegral sizeofCUSTDATA)
+    invokeAndCheck (\ methPtr iptr -> prim_System_Win32_Com_Automation_TypeLib_getAllCustData methPtr iptr pCustData) 16 iptr
+    doThenFree free (readCUSTDATA False) pCustData
+
+-- --------------------------------------------------
+-- 
+-- interface ITypeChangeEvents
+-- 
+-- --------------------------------------------------
+data ITypeChangeEvents_ a = ITypeChangeEvents__
+                              
+type ITypeChangeEvents a = IUnknown (ITypeChangeEvents_ a)
+iidITypeChangeEvents :: IID (ITypeChangeEvents ())
+iidITypeChangeEvents =
+  mkIID "{00020410-0000-0000-C000-000000000046}"
+
+type LPTYPECHANGEEVENTS = Maybe (ITypeChangeEvents ())
+data CHANGEKIND
+ = CHANGEKIND_ADDMEMBER
+ | CHANGEKIND_DELETEMEMBER
+ | CHANGEKIND_SETNAMES
+ | CHANGEKIND_SETDOCUMENTATION
+ | CHANGEKIND_GENERAL
+ | CHANGEKIND_INVALIDATE
+ | CHANGEKIND_CHANGEFAILED
+ | CHANGEKIND_MAX
+ deriving (Enum)
+requestTypeChange :: CHANGEKIND
+                  -> ITypeInfo a1
+                  -> LPOLESTR
+                  -> ITypeChangeEvents a0
+                  -> IO INT
+requestTypeChange changeKind pTInfoBefore pStrName iptr =
+  do
+    pfCancel <- allocBytes (fromIntegral sizeofInt32)
+    changeKind <- marshallEnum32 changeKind
+    pTInfoBefore <- marshallIUnknown pTInfoBefore
+    pStrName <- marshallWideString pStrName
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr pTInfoBefore (\ pTInfoBefore -> prim_System_Win32_Com_Automation_TypeLib_requestTypeChange methPtr iptr changeKind pTInfoBefore pStrName pfCancel)) 3 iptr
+    freeWideString pStrName
+    doThenFree free readInt32 pfCancel
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_requestTypeChange :: Ptr () -> Ptr () -> Int32 -> Ptr (ITypeInfo a) -> Ptr WideString -> Ptr Int32 -> IO Int32
+afterTypeChange :: CHANGEKIND
+                -> ITypeInfo a1
+                -> LPOLESTR
+                -> ITypeChangeEvents a0
+                -> IO ()
+afterTypeChange changeKind pTInfoAfter pStrName iptr =
+  do
+    changeKind <- marshallEnum32 changeKind
+    pTInfoAfter <- marshallIUnknown pTInfoAfter
+    pStrName <- marshallWideString pStrName
+    invokeAndCheck (\ methPtr iptr -> withForeignPtr pTInfoAfter (\ pTInfoAfter -> prim_System_Win32_Com_Automation_TypeLib_afterTypeChange methPtr iptr changeKind pTInfoAfter pStrName)) 4 iptr
+    freeWideString pStrName
+
+foreign import stdcall "dynamic" prim_System_Win32_Com_Automation_TypeLib_afterTypeChange :: Ptr () -> Ptr () -> Int32 -> Ptr (ITypeInfo a) -> Ptr WideString -> IO Int32
+
+ System/Win32/Com/Base.hs view
@@ -0,0 +1,675 @@+{-# OPTIONS -#include "comPrim.h" #-}
+-- Automatically generated by HaskellDirect (ihc.exe), snapshot 171208
+-- Created: 23:37 Pacific Standard Time, Wednesday 17 December, 2008
+-- Command line: -fno-qualified-names -fno-imports -fno-export-lists -fout-pointers-are-not-refs -c System/Win32/Com/Base.idl -o System/Win32/Com/Base.hs
+
+module System.Win32.Com.Base where
+
+
+
+import System.Win32.Com.HDirect.Pointer ( makeFO, finalNoFree )
+import System.Win32.Com.HDirect.HDirect
+import Foreign.ForeignPtr
+import Foreign.Ptr
+import Data.Dynamic
+{- BEGIN_GHC_ONLY
+import GHC.IOBase
+   END_GHC_ONLY -}
+import Data.Int
+import Data.Word       ( Word32 )
+import System.IO.Unsafe ( unsafePerformIO )
+import System.Win32.Com.HDirect.WideString ( WideString, marshallWideString, freeWideString,
+		    readWideString, writeWideString )
+import IO         ( hPutStrLn, stderr )
+
+newtype IUnknown_ a  = Unknown  (ForeignPtr ())
+type IUnknown  a  = IUnknown_ a
+
+type HRESULT = Int32
+
+failed    :: HRESULT -> Bool
+failed hr = hr < 0
+
+ifaceToAddr :: IUnknown a -> Ptr b
+ifaceToAddr (Unknown x)    = castPtr (foreignPtrToPtr x)
+
+addrToIPointer :: Bool -> Ptr b -> IO (IUnknown a)
+addrToIPointer finaliseMe x = do
+  i <- makeFO x (castPtrToFunPtr $ if finaliseMe then addrOfReleaseIUnknown else finalNoFree)
+  return (Unknown i)
+
+marshallIUnknown :: IUnknown a -> IO (ForeignPtr b)
+marshallIUnknown (Unknown x) = return (castForeignPtr x)
+
+checkHR :: HRESULT -> IO ()
+checkHR hr
+      | failed hr   = coFailHR hr
+      | otherwise   = return ()
+
+coFailHR :: HRESULT -> IO a
+coFailHR  hr         = do
+    str <- stringFromHR hr
+    coFailWithHR hr str
+
+{- BEGIN_GHC_ONLY
+-- ghc-specific
+newtype ComError = ComError Int32
+
+comErrorTc = mkTyCon "ComError"
+
+instance Typeable ComError where
+#if __GLASGOW_HASKELL__ < 604
+   typeOf _ = mkAppTy comErrorTc []
+#else
+   typeOf _ = mkTyConApp comErrorTc []
+#endif
+
+coFailWithHR :: HRESULT -> String -> IO a
+coFailWithHR hr msg = 
+  ioException (IOError Nothing (DynIOError (toDyn (ComError hr))) "" msg Nothing)
+   END_GHC_ONLY -}
+
+{- BEGIN_NOT_FOR_GHC -}
+coPrefix   = "Com error: "
+
+coFailWithHR :: HRESULT -> String -> IO a
+coFailWithHR hr msg = ioError (userError (coPrefix ++ msg ++ showParen True (shows hr) ""))
+{- END_NOT_FOR_GHC   -}
+
+stringFromHR :: HRESULT -> IO String
+stringFromHR hr = do
+  pstr <- hresultString hr  -- static memory
+  unmarshallString (castPtr pstr)
+
+
+comInitialize :: IO ()
+comInitialize =
+  do
+    o_comInitialize <- prim_System_Win32_Com_Base_comInitialize
+    checkHR o_comInitialize
+
+foreign import ccall "comInitialize" prim_System_Win32_Com_Base_comInitialize :: IO Int32
+comUnInitialize :: IO ()
+comUnInitialize =
+  prim_System_Win32_Com_Base_comUnInitialize
+
+foreign import ccall "comUnInitialize" prim_System_Win32_Com_Base_comUnInitialize :: IO ()
+messageBox :: Ptr Char
+           -> Ptr Char
+           -> Word32
+           -> IO ()
+messageBox str title flg =
+  prim_System_Win32_Com_Base_messageBox str
+                                        title
+                                        flg
+
+foreign import ccall "messageBox" prim_System_Win32_Com_Base_messageBox :: Ptr Char -> Ptr Char -> Word32 -> IO ()
+type PIID = Ptr ()
+type PCLSID = Ptr ()
+type PGUID = Ptr ()
+primCLSIDFromProgID :: Ptr Char
+                    -> PCLSID
+                    -> IO ()
+primCLSIDFromProgID str rptr =
+  do
+    o_primCLSIDFromProgID <- prim_System_Win32_Com_Base_primCLSIDFromProgID str rptr
+    checkHR o_primCLSIDFromProgID
+
+foreign import ccall "primCLSIDFromProgID" prim_System_Win32_Com_Base_primCLSIDFromProgID :: Ptr Char -> Ptr () -> IO Int32
+primProgIDFromCLSID :: ForeignPtr ()
+                    -> IO (Ptr ())
+primProgIDFromCLSID pclsid =
+  do
+    pwide <- allocBytes (fromIntegral sizeofPtr)
+    o_primProgIDFromCLSID <- withForeignPtr pclsid (\ pclsid -> prim_System_Win32_Com_Base_primProgIDFromCLSID pclsid pwide)
+    checkHR o_primProgIDFromCLSID
+    doThenFree free readPtr pwide
+
+foreign import ccall "primProgIDFromCLSID" prim_System_Win32_Com_Base_primProgIDFromCLSID :: Ptr () -> Ptr (Ptr ()) -> IO Int32
+primStringToGUID :: Ptr Wchar_t
+                 -> Ptr ()
+                 -> IO ()
+primStringToGUID str pguid =
+  do
+    o_primStringToGUID <- prim_System_Win32_Com_Base_primStringToGUID str pguid
+    checkHR o_primStringToGUID
+
+foreign import ccall "primStringToGUID" prim_System_Win32_Com_Base_primStringToGUID :: Ptr Word16 -> Ptr () -> IO Int32
+primGUIDToString :: ForeignPtr ()
+                 -> IO (Ptr ())
+primGUIDToString guid =
+  do
+    str <- allocBytes (fromIntegral sizeofPtr)
+    o_primGUIDToString <- withForeignPtr guid (\ guid -> prim_System_Win32_Com_Base_primGUIDToString guid str)
+    checkHR o_primGUIDToString
+    doThenFree free readPtr str
+
+foreign import ccall "primGUIDToString" prim_System_Win32_Com_Base_primGUIDToString :: Ptr () -> Ptr (Ptr ()) -> IO Int32
+primCopyGUID :: ForeignPtr ()
+             -> PGUID
+             -> IO ()
+primCopyGUID pguid1 pguid2 =
+  do
+    o_primCopyGUID <- withForeignPtr pguid1 (\ pguid1 -> prim_System_Win32_Com_Base_primCopyGUID pguid1 pguid2)
+    checkHR o_primCopyGUID
+
+foreign import ccall "primCopyGUID" prim_System_Win32_Com_Base_primCopyGUID :: Ptr () -> Ptr () -> IO Int32
+primNewGUID :: ForeignPtr ()
+            -> IO ()
+primNewGUID pguid =
+  do
+    o_primNewGUID <- withForeignPtr pguid (\ pguid -> prim_System_Win32_Com_Base_primNewGUID pguid)
+    checkHR o_primNewGUID
+
+foreign import ccall "primNewGUID" prim_System_Win32_Com_Base_primNewGUID :: Ptr () -> IO Int32
+bindObject :: Ptr Wchar_t
+           -> ForeignPtr ()
+           -> IO (Ptr (Ptr ()))
+bindObject name iid =
+  do
+    ppv <- allocBytes (fromIntegral sizeofPtr)
+    o_bindObject <- withForeignPtr iid (\ iid -> prim_System_Win32_Com_Base_bindObject name iid ppv)
+    checkHR o_bindObject
+    return (ppv)
+
+foreign import ccall "bindObject" prim_System_Win32_Com_Base_bindObject :: Ptr Word16 -> Ptr () -> Ptr (Ptr ()) -> IO Int32
+primComEqual :: IUnknown a0
+             -> IUnknown a1
+             -> IO Bool
+primComEqual unk1 unk2 =
+  do
+    unk1 <- marshallIUnknown unk1
+    unk2 <- marshallIUnknown unk2
+    o_primComEqual <- withForeignPtr unk1 (\ unk1 -> withForeignPtr unk2 (\ unk2 -> prim_System_Win32_Com_Base_primComEqual unk1 unk2))
+    unmarshallBool o_primComEqual
+
+foreign import ccall "primComEqual" prim_System_Win32_Com_Base_primComEqual :: Ptr (IUnknown a) -> Ptr (IUnknown a) -> IO Int32
+isEqualGUID :: ForeignPtr ()
+            -> ForeignPtr ()
+            -> Bool
+isEqualGUID guid1 guid2 =
+  unsafePerformIO (withForeignPtr guid1 (\ guid1 -> withForeignPtr guid2 (\ guid2 -> prim_System_Win32_Com_Base_isEqualGUID guid1 guid2)) >>= \ o_isEqualGUID ->
+                   unmarshallBool o_isEqualGUID)
+
+foreign import stdcall "IsEqualGUID" prim_System_Win32_Com_Base_isEqualGUID :: Ptr () -> Ptr () -> IO Int32
+lOCALE_USER_DEFAULT :: Word32
+lOCALE_USER_DEFAULT =
+  unsafePerformIO (prim_System_Win32_Com_Base_lOCALE_USER_DEFAULT)
+
+foreign import ccall "lOCALE_USER_DEFAULT" prim_System_Win32_Com_Base_lOCALE_USER_DEFAULT :: IO Word32
+primCreateTypeLib :: Int32
+                  -> WideString
+                  -> IO (Ptr (Ptr ()))
+primCreateTypeLib skind lpkind =
+  do
+    ppv <- allocBytes (fromIntegral sizeofPtr)
+    lpkind <- marshallWideString lpkind
+    o_primCreateTypeLib <- prim_System_Win32_Com_Base_primCreateTypeLib skind lpkind ppv
+    freeWideString lpkind
+    checkHR o_primCreateTypeLib
+    return (ppv)
+
+foreign import ccall "primCreateTypeLib" prim_System_Win32_Com_Base_primCreateTypeLib :: Int32 -> Ptr WideString -> Ptr (Ptr ()) -> IO Int32
+getLastError :: IO Word32
+getLastError = prim_System_Win32_Com_Base_getLastError
+
+foreign import stdcall "GetLastError" prim_System_Win32_Com_Base_getLastError :: IO Word32
+hresultString :: Int32
+              -> IO (Ptr ())
+hresultString i = prim_System_Win32_Com_Base_hresultString i
+
+foreign import ccall "hresultString" prim_System_Win32_Com_Base_hresultString :: Int32 -> IO (Ptr ())
+coCreateInstance :: ForeignPtr ()
+                 -> ForeignPtr ()
+                 -> Int32
+                 -> ForeignPtr ()
+                 -> Ptr ()
+                 -> IO ()
+coCreateInstance clsid inner ctxt riid ppv =
+  do
+    o_coCreateInstance <- withForeignPtr clsid (\ clsid -> withForeignPtr inner (\ inner -> withForeignPtr riid (\ riid -> prim_System_Win32_Com_Base_coCreateInstance clsid inner ctxt riid ppv)))
+    checkHR o_coCreateInstance
+
+foreign import stdcall "CoCreateInstance" prim_System_Win32_Com_Base_coCreateInstance :: Ptr () -> Ptr () -> Int32 -> Ptr () -> Ptr () -> IO Int32
+type ULONG = Word32
+type DWORD = Word32
+data COAUTHIDENTITY = COAUTHIDENTITY {user :: String,
+                                      domain :: String,
+                                      password :: String,
+                                      flags :: ULONG}
+                        
+writeCOAUTHIDENTITY :: Ptr COAUTHIDENTITY
+                    -> COAUTHIDENTITY
+                    -> IO ()
+writeCOAUTHIDENTITY ptr (COAUTHIDENTITY user domain password flags) =
+  let
+   userLength = (fromIntegral (length user) :: Word32)
+  in
+  do
+    user <- marshallString user
+    let domainLength = (fromIntegral (length domain) :: Word32)
+    domain <- marshallString domain
+    let passwordLength = (fromIntegral (length password) :: Word32)
+    password <- marshallString password
+    let pf0 = ptr
+        pf1 = addNCastPtr pf0 0
+    writePtr pf1 user
+    let pf2 = addNCastPtr pf1 4
+    writeWord32 pf2 userLength
+    let pf3 = addNCastPtr pf2 4
+    writePtr pf3 domain
+    let pf4 = addNCastPtr pf3 4
+    writeWord32 pf4 domainLength
+    let pf5 = addNCastPtr pf4 4
+    writePtr pf5 password
+    let pf6 = addNCastPtr pf5 4
+    writeWord32 pf6 passwordLength
+    let pf7 = addNCastPtr pf6 4
+    writeWord32 pf7 flags
+
+readCOAUTHIDENTITY :: Ptr COAUTHIDENTITY
+                   -> IO COAUTHIDENTITY
+readCOAUTHIDENTITY ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    user <- readPtr pf1
+    let pf2 = addNCastPtr pf1 4
+    userLength <- readWord32 pf2
+    let pf3 = addNCastPtr pf2 4
+    domain <- readPtr pf3
+    let pf4 = addNCastPtr pf3 4
+    domainLength <- readWord32 pf4
+    let pf5 = addNCastPtr pf4 4
+    password <- readPtr pf5
+    let pf6 = addNCastPtr pf5 4
+    passwordLength <- readWord32 pf6
+    let pf7 = addNCastPtr pf6 4
+    flags <- readWord32 pf7
+    userLength <- unmarshallWord32 userLength
+    domainLength <- unmarshallWord32 domainLength
+    passwordLength <- unmarshallWord32 passwordLength
+    user <- unmarshallString user
+    domain <- unmarshallString domain
+    password <- unmarshallString password
+    return (COAUTHIDENTITY user domain password flags)
+
+sizeofCOAUTHIDENTITY :: Word32
+sizeofCOAUTHIDENTITY = 28
+
+data COAUTHINFO = COAUTHINFO {dwAuthnSvc :: DWORD,
+                              dwAuthzSvc :: DWORD,
+                              pwszServerPrincName :: WideString,
+                              dwAuthnLevel :: DWORD,
+                              dwImpersonationLevel :: DWORD,
+                              pAuthIdentityData :: (Maybe COAUTHIDENTITY),
+                              dwCapabilities :: DWORD}
+                    
+writeCOAUTHINFO :: Ptr COAUTHINFO
+                -> COAUTHINFO
+                -> IO ()
+writeCOAUTHINFO ptr (COAUTHINFO dwAuthnSvc dwAuthzSvc pwszServerPrincName dwAuthnLevel dwImpersonationLevel pAuthIdentityData dwCapabilities) =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    writeWord32 pf1 dwAuthnSvc
+    let pf2 = addNCastPtr pf1 4
+    writeWord32 pf2 dwAuthzSvc
+    let pf3 = addNCastPtr pf2 4
+    writeWideString pf3 pwszServerPrincName
+    let pf4 = addNCastPtr pf3 4
+    writeWord32 pf4 dwAuthnLevel
+    let pf5 = addNCastPtr pf4 4
+    writeWord32 pf5 dwImpersonationLevel
+    let pf6 = addNCastPtr pf5 4
+    writeunique (allocBytes (fromIntegral sizeofCOAUTHIDENTITY)) writeCOAUTHIDENTITY pf6 pAuthIdentityData
+    let pf7 = addNCastPtr pf6 4
+    writeWord32 pf7 dwCapabilities
+
+readCOAUTHINFO :: Ptr COAUTHINFO
+               -> IO COAUTHINFO
+readCOAUTHINFO ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    dwAuthnSvc <- readWord32 pf1
+    let pf2 = addNCastPtr pf1 4
+    dwAuthzSvc <- readWord32 pf2
+    let pf3 = addNCastPtr pf2 4
+    pwszServerPrincName <- readWideString pf3
+    let pf4 = addNCastPtr pf3 4
+    dwAuthnLevel <- readWord32 pf4
+    let pf5 = addNCastPtr pf4 4
+    dwImpersonationLevel <- readWord32 pf5
+    let pf6 = addNCastPtr pf5 4
+    pAuthIdentityData <- readunique readCOAUTHIDENTITY pf6
+    let pf7 = addNCastPtr pf6 4
+    dwCapabilities <- readWord32 pf7
+    return (COAUTHINFO dwAuthnSvc dwAuthzSvc pwszServerPrincName dwAuthnLevel dwImpersonationLevel pAuthIdentityData dwCapabilities)
+
+sizeofCOAUTHINFO :: Word32
+sizeofCOAUTHINFO = 28
+
+data COSERVERINFO = COSERVERINFO {dwReserved1 :: DWORD,
+                                  pwszName :: WideString,
+                                  pAuthInfo :: (Maybe COAUTHINFO),
+                                  dwReserved2 :: DWORD}
+                      
+writeCOSERVERINFO :: Ptr COSERVERINFO
+                  -> COSERVERINFO
+                  -> IO ()
+writeCOSERVERINFO ptr (COSERVERINFO dwReserved1 pwszName pAuthInfo dwReserved2) =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    writeWord32 pf1 dwReserved1
+    let pf2 = addNCastPtr pf1 4
+    writeWideString pf2 pwszName
+    let pf3 = addNCastPtr pf2 4
+    writeunique (allocBytes (fromIntegral sizeofCOAUTHINFO)) writeCOAUTHINFO pf3 pAuthInfo
+    let pf4 = addNCastPtr pf3 4
+    writeWord32 pf4 dwReserved2
+
+readCOSERVERINFO :: Ptr COSERVERINFO
+                 -> IO COSERVERINFO
+readCOSERVERINFO ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    dwReserved1 <- readWord32 pf1
+    let pf2 = addNCastPtr pf1 4
+    pwszName <- readWideString pf2
+    let pf3 = addNCastPtr pf2 4
+    pAuthInfo <- readunique readCOAUTHINFO pf3
+    let pf4 = addNCastPtr pf3 4
+    dwReserved2 <- readWord32 pf4
+    return (COSERVERINFO dwReserved1 pwszName pAuthInfo dwReserved2)
+
+sizeofCOSERVERINFO :: Word32
+sizeofCOSERVERINFO = 16
+
+data MULTI_QI_PRIM = MULTI_QI {pIID :: PGUID,
+                               pItf :: (Ptr ()),
+                               hr :: HRESULT}
+                       
+writeMULTI_QI_PRIM :: Ptr MULTI_QI_PRIM
+                   -> MULTI_QI_PRIM
+                   -> IO ()
+writeMULTI_QI_PRIM ptr (MULTI_QI pIID pItf hr) =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    writePtr pf1 pIID
+    let pf2 = addNCastPtr pf1 4
+    writePtr pf2 pItf
+    let pf3 = addNCastPtr pf2 4
+    writeInt32 pf3 hr
+
+readMULTI_QI_PRIM :: Ptr MULTI_QI_PRIM
+                  -> IO MULTI_QI_PRIM
+readMULTI_QI_PRIM ptr =
+  let
+   pf0 = ptr
+   pf1 = addNCastPtr pf0 0
+  in
+  do
+    pIID <- readPtr pf1
+    let pf2 = addNCastPtr pf1 4
+    pItf <- readPtr pf2
+    let pf3 = addNCastPtr pf2 4
+    hr <- readInt32 pf3
+    return (MULTI_QI pIID pItf hr)
+
+sizeofMULTI_QI_PRIM :: Word32
+sizeofMULTI_QI_PRIM = 12
+
+coCreateInstanceEx :: ForeignPtr ()
+                   -> ForeignPtr ()
+                   -> DWORD
+                   -> Maybe COSERVERINFO
+                   -> [MULTI_QI_PRIM]
+                   -> IO [MULTI_QI_PRIM]
+coCreateInstanceEx clsid pUnkOuter dwClsCtx pServerInfo pResults =
+  let
+   cmq = (fromIntegral (length pResults) :: Word32)
+  in
+  do
+    pResults <- marshalllist sizeofMULTI_QI_PRIM writeMULTI_QI_PRIM pResults
+    pServerInfo <- marshallunique (allocBytes (fromIntegral sizeofCOSERVERINFO)) writeCOSERVERINFO pServerInfo
+    o_coCreateInstanceEx <- withForeignPtr clsid (\ clsid -> withForeignPtr pUnkOuter (\ pUnkOuter -> prim_System_Win32_Com_Base_coCreateInstanceEx clsid pUnkOuter dwClsCtx pServerInfo cmq pResults))
+    free pServerInfo
+    checkHR o_coCreateInstanceEx
+    cmq <- unmarshallWord32 cmq
+    unmarshalllist sizeofMULTI_QI_PRIM 0 cmq readMULTI_QI_PRIM pResults
+
+foreign import stdcall "CoCreateInstanceEx" prim_System_Win32_Com_Base_coCreateInstanceEx :: Ptr () -> Ptr () -> Word32 -> Ptr COSERVERINFO -> Word32 -> Ptr MULTI_QI_PRIM -> IO Int32
+getActiveObject :: ForeignPtr ()
+                -> Ptr ()
+                -> Ptr ()
+                -> IO ()
+getActiveObject clsid inner ppv =
+  do
+    o_getActiveObject <- withForeignPtr clsid (\ clsid -> prim_System_Win32_Com_Base_getActiveObject clsid inner ppv)
+    checkHR o_getActiveObject
+
+foreign import stdcall "GetActiveObject" prim_System_Win32_Com_Base_getActiveObject :: Ptr () -> Ptr () -> Ptr () -> IO Int32
+primQI :: Ptr ()
+       -> Ptr ()
+       -> ForeignPtr ()
+       -> Ptr (Ptr ())
+       -> IO ()
+primQI methPtr iptr riid ppv =
+  do
+    o_primQI <- withForeignPtr riid (\ riid -> prim_System_Win32_Com_Base_primQI methPtr iptr riid ppv)
+    checkHR o_primQI
+
+foreign import ccall "primQI" prim_System_Win32_Com_Base_primQI :: Ptr () -> Ptr () -> Ptr () -> Ptr (Ptr ()) -> IO Int32
+primAddRef :: Ptr ()
+           -> Ptr ()
+           -> IO Word32
+primAddRef methPtr iptr =
+  prim_System_Win32_Com_Base_primAddRef methPtr
+                                        iptr
+
+foreign import ccall "primAddRef" prim_System_Win32_Com_Base_primAddRef :: Ptr () -> Ptr () -> IO Word32
+primRelease :: Ptr ()
+            -> Ptr ()
+            -> IO Word32
+primRelease methPtr iptr =
+  prim_System_Win32_Com_Base_primRelease methPtr
+                                         iptr
+
+foreign import ccall "primRelease" prim_System_Win32_Com_Base_primRelease :: Ptr () -> Ptr () -> IO Word32
+primEnumNext :: Ptr ()
+             -> Ptr ()
+             -> Word32
+             -> Ptr ()
+             -> Ptr ()
+             -> IO ()
+primEnumNext methPtr iptr celt ptr po =
+  do
+    o_primEnumNext <- prim_System_Win32_Com_Base_primEnumNext methPtr iptr celt ptr po
+    checkHR o_primEnumNext
+
+foreign import ccall "primEnumNext" prim_System_Win32_Com_Base_primEnumNext :: Ptr () -> Ptr () -> Word32 -> Ptr () -> Ptr () -> IO Int32
+primEnumSkip :: Ptr ()
+             -> Ptr ()
+             -> Word32
+             -> IO ()
+primEnumSkip methPtr iptr celt =
+  do
+    o_primEnumSkip <- prim_System_Win32_Com_Base_primEnumSkip methPtr iptr celt
+    checkHR o_primEnumSkip
+
+foreign import ccall "primEnumSkip" prim_System_Win32_Com_Base_primEnumSkip :: Ptr () -> Ptr () -> Word32 -> IO Int32
+primEnumReset :: Ptr ()
+              -> Ptr ()
+              -> IO ()
+primEnumReset methPtr iptr =
+  do
+    o_primEnumReset <- prim_System_Win32_Com_Base_primEnumReset methPtr iptr
+    checkHR o_primEnumReset
+
+foreign import ccall "primEnumReset" prim_System_Win32_Com_Base_primEnumReset :: Ptr () -> Ptr () -> IO Int32
+primEnumClone :: Ptr ()
+              -> Ptr ()
+              -> Ptr ()
+              -> IO ()
+primEnumClone methPtr iptr ppv =
+  do
+    o_primEnumClone <- prim_System_Win32_Com_Base_primEnumClone methPtr iptr ppv
+    checkHR o_primEnumClone
+
+foreign import ccall "primEnumClone" prim_System_Win32_Com_Base_primEnumClone :: Ptr () -> Ptr () -> Ptr () -> IO Int32
+primPersistLoad :: Ptr ()
+                -> Ptr ()
+                -> Ptr Wchar_t
+                -> Word32
+                -> IO ()
+primPersistLoad methPtr iptr pszFileName dwMode =
+  do
+    o_primPersistLoad <- prim_System_Win32_Com_Base_primPersistLoad methPtr iptr pszFileName dwMode
+    checkHR o_primPersistLoad
+
+foreign import ccall "primPersistLoad" prim_System_Win32_Com_Base_primPersistLoad :: Ptr () -> Ptr () -> Ptr Word16 -> Word32 -> IO Int32
+primNullIID :: IO (Ptr ())
+primNullIID = prim_System_Win32_Com_Base_primNullIID
+
+foreign import ccall "primNullIID" prim_System_Win32_Com_Base_primNullIID :: IO (Ptr ())
+loadTypeLib :: Ptr Wchar_t
+            -> Ptr ()
+            -> IO ()
+loadTypeLib pfname ptr =
+  do
+    o_loadTypeLib <- prim_System_Win32_Com_Base_loadTypeLib pfname ptr
+    checkHR o_loadTypeLib
+
+foreign import stdcall "LoadTypeLib" prim_System_Win32_Com_Base_loadTypeLib :: Ptr Word16 -> Ptr () -> IO Int32
+loadTypeLibEx :: Ptr Wchar_t
+              -> Int32
+              -> Ptr ()
+              -> IO ()
+loadTypeLibEx pfname rkind ptr =
+  do
+    o_loadTypeLibEx <- prim_System_Win32_Com_Base_loadTypeLibEx pfname rkind ptr
+    checkHR o_loadTypeLibEx
+
+foreign import stdcall "LoadTypeLibEx" prim_System_Win32_Com_Base_loadTypeLibEx :: Ptr Word16 -> Int32 -> Ptr () -> IO Int32
+loadRegTypeLib :: ForeignPtr ()
+               -> Int32
+               -> Int32
+               -> Int32
+               -> Ptr ()
+               -> IO ()
+loadRegTypeLib pguid maj min lcid ptr =
+  do
+    o_loadRegTypeLib <- withForeignPtr pguid (\ pguid -> prim_System_Win32_Com_Base_loadRegTypeLib pguid maj min lcid ptr)
+    checkHR o_loadRegTypeLib
+
+foreign import stdcall "LoadRegTypeLib" prim_System_Win32_Com_Base_loadRegTypeLib :: Ptr () -> Int32 -> Int32 -> Int32 -> Ptr () -> IO Int32
+primQueryPathOfRegTypeLib :: ForeignPtr ()
+                          -> Word16
+                          -> Word16
+                          -> IO (Ptr Wchar_t)
+primQueryPathOfRegTypeLib pgd maj min =
+  withForeignPtr pgd
+                 (\ pgd -> prim_System_Win32_Com_Base_primQueryPathOfRegTypeLib pgd maj min)
+
+foreign import ccall "primQueryPathOfRegTypeLib" prim_System_Win32_Com_Base_primQueryPathOfRegTypeLib :: Ptr () -> Word16 -> Word16 -> IO (Ptr Word16)
+addrOfReleaseIUnknown :: Ptr ()
+addrOfReleaseIUnknown =
+  unsafePerformIO (prim_System_Win32_Com_Base_addrOfReleaseIUnknown)
+
+foreign import ccall "addrOfReleaseIUnknown" prim_System_Win32_Com_Base_addrOfReleaseIUnknown :: IO (Ptr ())
+bstrToStringLen :: Ptr String
+                -> Int32
+                -> Ptr Char
+                -> IO ()
+bstrToStringLen bstr len str =
+  do
+    o_bstrToStringLen <- prim_System_Win32_Com_Base_bstrToStringLen bstr len str
+    checkHR o_bstrToStringLen
+
+foreign import ccall "bstrToStringLen" prim_System_Win32_Com_Base_bstrToStringLen :: Ptr String -> Int32 -> Ptr Char -> IO Int32
+bstrLen :: Ptr String
+        -> Int32
+bstrLen bstr =
+  unsafePerformIO (prim_System_Win32_Com_Base_bstrLen bstr)
+
+foreign import ccall "bstrLen" prim_System_Win32_Com_Base_bstrLen :: Ptr String -> IO Int32
+stringToBSTR :: Ptr String
+             -> IO (Ptr String)
+stringToBSTR bstr =
+  do
+    res <- allocBytes (fromIntegral sizeofPtr)
+    o_stringToBSTR <- prim_System_Win32_Com_Base_stringToBSTR bstr res
+    checkHR o_stringToBSTR
+    return (res)
+
+foreign import ccall "stringToBSTR" prim_System_Win32_Com_Base_stringToBSTR :: Ptr String -> Ptr String -> IO Int32
+getModuleFileName :: Ptr ()
+                  -> IO String
+getModuleFileName hModule =
+  do
+    o_getModuleFileName <- prim_System_Win32_Com_Base_getModuleFileName hModule
+    doThenFree freeString unmarshallString o_getModuleFileName
+
+foreign import ccall "getModuleFileName" prim_System_Win32_Com_Base_getModuleFileName :: Ptr () -> IO (Ptr String)
+messagePump :: IO ()
+messagePump =
+  prim_System_Win32_Com_Base_messagePump
+
+foreign import ccall "messagePump" prim_System_Win32_Com_Base_messagePump :: IO ()
+postQuitMsg :: IO ()
+postQuitMsg =
+  prim_System_Win32_Com_Base_postQuitMsg
+
+foreign import ccall "postQuitMsg" prim_System_Win32_Com_Base_postQuitMsg :: IO ()
+primOutputDebugString :: String
+                      -> IO ()
+primOutputDebugString msg =
+  do
+    msg <- marshallString msg
+    prim_System_Win32_Com_Base_primOutputDebugString msg
+    freeString msg
+
+foreign import stdcall "OutputDebugStringA" prim_System_Win32_Com_Base_primOutputDebugString :: Ptr String -> IO ()
+primGetVersionInfo :: IO (Word32, Word32, Word32)
+primGetVersionInfo =
+  do
+    maj <- allocBytes (fromIntegral sizeofWord32)
+    min <- allocBytes (fromIntegral sizeofWord32)
+    pid <- allocBytes (fromIntegral sizeofWord32)
+    prim_System_Win32_Com_Base_primGetVersionInfo maj min pid
+    maj <- doThenFree free readWord32 maj
+    min <- doThenFree free readWord32 min
+    pid <- doThenFree free readWord32 pid
+    return (maj, min, pid)
+
+foreign import ccall "primGetVersionInfo" prim_System_Win32_Com_Base_primGetVersionInfo :: Ptr Word32 -> Ptr Word32 -> Ptr Word32 -> IO ()
+coRegisterClassObject :: ForeignPtr ()
+                      -> ForeignPtr ()
+                      -> Int32
+                      -> Int32
+                      -> IO Word32
+coRegisterClassObject rclsid pUnk dwClsContext flags0 =
+  do
+    lpwRegister <- allocBytes (fromIntegral sizeofWord32)
+    o_coRegisterClassObject <- withForeignPtr rclsid (\ rclsid -> withForeignPtr pUnk (\ pUnk -> prim_System_Win32_Com_Base_coRegisterClassObject rclsid pUnk dwClsContext flags0 lpwRegister))
+    checkHR o_coRegisterClassObject
+    doThenFree free readWord32 lpwRegister
+
+foreign import stdcall "CoRegisterClassObject" prim_System_Win32_Com_Base_coRegisterClassObject :: Ptr () -> Ptr () -> Int32 -> Int32 -> Ptr Word32 -> IO Int32
+
+ System/Win32/Com/ClassFactory.hs view
@@ -0,0 +1,95 @@+{-# OPTIONS -#include "ClassFactory_stub.h" #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Win32.Com.ClassFactory
+-- 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
+--
+-- Haskell implementation of a COM class factory \/ component instance creator.
+-- 
+-----------------------------------------------------------------------------
+module System.Win32.Com.ClassFactory 
+	(
+	  createClassFactory -- :: (IID a -> IO (PrimIP a)) -> IO (PrimIP ())
+
+        , iidIClassFactory
+	) where
+
+import System.Win32.Com
+import System.Win32.Com.Server hiding ( createInstance )
+import Foreign.Ptr
+import System.Win32.Com.Exception     ( cLASS_E_NOAGGREGATION )
+import System.IO.Unsafe ( unsafePerformIO )
+import Data.IORef       ( IORef, newIORef, readIORef, writeIORef )
+
+data ClassFactory a
+ = ClassFactory {
+         new_instance :: (IID (IUnknown ()) -> IO (IUnknown ())),
+	 lockCount    :: (IORef Int)
+   }
+
+type IClassFactory a = IUnknown (ClassFactory a)
+
+type This_ClassFactory = Ptr (IClassFactory ())
+
+iidIClassFactory :: IID (IClassFactory ())
+iidIClassFactory = mkIID "{00000001-0000-0000-C000-000000000046}"
+
+--Class factory implementation:
+
+createInstance :: This_ClassFactory 
+               -> Ptr (IUnknown a)
+	       -> Ptr (IID (IUnknown ()))
+	       -> Ptr (Ptr (IUnknown b))
+	       -> IO HRESULT
+createInstance this punkOuter riid ppv
+ | punkOuter /= nullPtr = return cLASS_E_NOAGGREGATION
+ | otherwise            = do
+    st  <- getObjState this
+    iid <- unmarshallIID False riid
+    unk <- (new_instance st) iid
+    writeIUnknown True ppv unk
+    return s_OK
+
+lockServer :: This_ClassFactory -> Int -> IO HRESULT
+lockServer this ilock = do
+    st    <- getObjState this
+    let ref = lockCount st
+    count <- readIORef ref
+    if lock then
+      writeIORef ref (count+1)
+     else
+      writeIORef ref (count-1)
+    return s_OK
+  where
+   lock 
+    | ilock == 0 = False
+    | otherwise  = True
+
+foreign import stdcall "wrapper"
+   export_createInstance :: (This_ClassFactory -> Ptr (IUnknown a) -> Ptr (IID (IUnknown ())) -> Ptr (Ptr (IUnknown b)) -> IO HRESULT) -> IO (Ptr ())
+
+foreign import stdcall "wrapper"
+   export_lockServer :: (Ptr (IUnknown a) -> Int -> IO HRESULT) -> IO (Ptr ())
+
+createClassFactory :: (IID (IUnknown ()) -> IO (IUnknown ()))
+		   -> IO (IClassFactory ())
+createClassFactory mkInst = do
+   lcount <- newIORef 0
+   let cf_state = ClassFactory mkInst lcount
+   createComInstance ""
+                     cf_state (return ())
+		     [mkIface iidIClassFactory iClassFactory_vtbl]
+		     iidIClassFactory
+ where
+  guidIClassFactory = iidToGUID iidIClassFactory
+
+iClassFactory_vtbl :: VTable (IClassFactory ()) (ClassFactory ())
+iClassFactory_vtbl = unsafePerformIO $ do
+   addrOf_cI <- export_createInstance createInstance
+   addrOf_lS <- export_lockServer     lockServer
+   createComVTable [addrOf_cI, addrOf_lS]
+ System/Win32/Com/Dll.hs view
@@ -0,0 +1,308 @@+{-# OPTIONS -#include "System/Win32/Com/Dll_stub.h" -#include <windows.h> -#include "Registry.h" #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Win32.Com.Dll
+-- 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 for sealing up Haskell code as an in-proc COM server.
+--
+-- The export list is odd in that it doesn't export the Haskell functions 
+-- required to implement the class factory, but rather an action which
+-- exposes them via a COM-like interface.
+-- 
+-----------------------------------------------------------------------------
+module System.Win32.Com.Dll
+	(  
+	   ComponentInfo(..)
+	,  mkComponentInfo
+	,  withComponentName
+	,  withProgID
+	,  withVerIndepProgID
+	,  onRegister
+	,  onFinalize
+	,  hasTypeLib
+
+	,  createIComDll   -- :: Ptr (){-HMODULE-} -> [ComponentInfo] -> IO
+
+	,  regAddEntry
+	,  regRemoveEntry
+	,  RegHive(..)
+	
+	,  stdRegComponent
+	,  stdUnRegComponent
+	) where
+
+import System.Win32.Com.ClassFactory
+import System.Win32.Com
+import System.Win32.Com.Exception
+import System.Win32.Com.Server
+import System.Win32.Com.Base ( getModuleFileName )
+import System.Win32.Com.HDirect.HDirect ( Ptr, marshallString )
+
+import Foreign  hiding ( Ptr )
+import Data.Word ( Word32 )
+import System.Win32.Com.HDirect.HDirect ( marshallMaybe )
+import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
+
+import Control.Monad
+import Data.List  ( find )
+
+{-
+The information an implementation of a Haskell COM component
+needs to supply in order to hook into the machinery provided
+here for interfacing to how COM does activation for in-proc
+components:
+-}
+
+data ComponentInfo
+  = ComponentInfo
+      { newInstance       :: String -> IO () -> IID (IUnknown ()) -> IO (IUnknown ())
+      , componentFinalise :: IO ()
+      , componentName     :: String
+      , componentProgID   :: String
+      , componentVProgID  :: String
+      , componentTLB      :: Bool
+      , registerComponent :: ComponentInfo -> String -> Bool -> IO ()
+      , componentCLSID    :: CLSID
+      }
+
+withProgID :: String -> ComponentInfo -> ComponentInfo
+withProgID p info = info{componentProgID=p}
+
+onRegister :: (ComponentInfo -> String -> Bool -> IO ()) -> ComponentInfo -> ComponentInfo
+onRegister reg info = 
+  info{registerComponent= \ a b c -> reg a b c >> (registerComponent info) a b c}
+
+onFinalize :: IO () -> ComponentInfo -> ComponentInfo
+onFinalize act info = info{componentFinalise= act >> (componentFinalise info)}
+
+withVerIndepProgID :: String -> ComponentInfo -> ComponentInfo
+withVerIndepProgID p info = info{componentVProgID=p}
+
+withFinaliser :: IO () -> ComponentInfo -> ComponentInfo
+withFinaliser act info = info{componentFinalise=act}
+
+withComponentName :: String -> ComponentInfo -> ComponentInfo
+withComponentName n info = info{componentName=n}
+
+hasTypeLib :: ComponentInfo -> ComponentInfo
+hasTypeLib info = info{componentTLB=True}
+
+ -- constructor used to lessen the reliance on concrete rep.
+mkComponentInfo :: CLSID
+		-> (String -> Bool -> IO ())
+		-> (String -> IO () -> IID (IUnknown ()) -> IO (IUnknown ()))
+		-> ComponentInfo
+mkComponentInfo cls reg n = ComponentInfo n (return ()) "" "" "" False (\ _ -> reg) cls
+
+--The state maintained by each instance of a 'ComDll' wrapper:
+
+data ComDllState
+  = ComDllState {
+      dllPath    :: String,
+      components :: IORef [ComponentInfo],
+      lockCount  :: IORef Int
+     }
+
+dllGetClassObject :: ComDllState -> Ptr CLSID -> Ptr (IID a) -> Ptr (Ptr (IUnknown a)) -> IO HRESULT
+dllGetClassObject comDll rclsid riid ppvObject = do
+  iid <- unmarshallIID False (castPtr riid)
+  let g = iidToGUID iid
+  if ( not (g == iidToGUID iidIClassFactory || g == iidToGUID iidIUnknown) ) then
+     return e_NOINTERFACE
+   else do
+    clsid <- unmarshallCLSID False rclsid
+    cs    <- readIORef (components comDll)
+    case lookupCLSID clsid cs of
+      Nothing -> return cLASS_E_CLASSNOTAVAILABLE
+      Just i  -> do
+         ip <- createClassFactory (newInstance i (dllPath comDll) (componentFinalise i))
+	 writeIUnknown False ppvObject ip
+	 return s_OK
+
+lookupCLSID :: CLSID -> [ComponentInfo] -> Maybe ComponentInfo
+lookupCLSID clsid cs = find (\ x -> clsidToGUID (componentCLSID x) == guid) cs
+ where
+  guid = clsidToGUID clsid
+
+dllCanUnloadNow :: ComDllState -> IO HRESULT
+dllCanUnloadNow state = do
+   c <- readIORef (lockCount state)
+   if c == 0 then 
+     return s_OK
+    else
+     return s_FALSE
+
+dllRegisterServer :: ComDllState -> IO HRESULT
+dllRegisterServer = registerServer True
+
+dllUnregisterServer :: ComDllState -> IO HRESULT
+dllUnregisterServer = registerServer False
+
+registerServer :: Bool -> ComDllState -> IO HRESULT
+registerServer isReg st = do
+  cs   <- readIORef (components st)
+  let
+   path = dllPath st
+   regComponent info
+     | not isReg = do
+	 -- give the user-supplied un-reg action the opportunity
+	 -- to delete some entries first.
+       (registerComponent info) info path isReg
+       stdUnRegComponent info True path
+     | otherwise = do
+       stdRegComponent info True path
+       (registerComponent info) info path isReg
+
+
+  mapM_ regComponent cs
+  case s_OK of
+    14 -> return s_OK
+    x  -> return x
+
+dllUnload :: ComDllState -> IO ()
+dllUnload st = return ()
+
+-- Creating + manipulating the state of a Haskell DLL containing
+-- Haskell COM server(s).
+
+newComDllState :: Ptr (){-HANDLE-} -> [ComponentInfo] -> IO ComDllState
+newComDllState hMod cs = do
+  path   <- getModuleFileName hMod
+  ref_cs <- newIORef cs
+    -- The lock count is intended used by DllCanUnloadNow() to keep
+    -- track of when the Com DLL can safely be unloaded. It is only
+    -- safe to do so if no COM interface pointers handed out by the 
+    -- component are currently alive.
+    --
+    -- The Com library doesn't yet try to keep track of this, so the
+    -- lock count is always left at 1 (==> DllCanUnloadNow() always returns
+    -- S_FALSE.)
+  lc     <- newIORef 1
+  return (ComDllState path ref_cs lc)
+
+createIComDll :: Ptr (){-HMODULE-} -> [ComponentInfo] -> IO (VTable iid_comDllState ComDllState)
+createIComDll hMod components = do
+   state       <- newComDllState hMod components
+   meths       <- iComDllEntryPoints state
+   createVTable meths
+
+iComDllEntryPoints :: ComDllState -> IO [Ptr ()]
+iComDllEntryPoints state = do
+  addrOf_DllUnload	     <- export_DllUnload   (dllUnload state)
+  addrOf_DllCanUnloadNow     <- export_nullaryMeth (dllCanUnloadNow state)
+  addrOf_DllRegisterServer   <- export_nullaryMeth (dllRegisterServer state)
+  addrOf_DllUnregisterServer <- export_nullaryMeth (dllUnregisterServer state)
+  addrOf_DllGetClassObject   <- export_dllGetClassObject (dllGetClassObject state)
+  return [ addrOf_DllUnload
+         , addrOf_DllCanUnloadNow
+	 , addrOf_DllRegisterServer
+	 , addrOf_DllUnregisterServer
+	 , addrOf_DllGetClassObject
+	 ]
+
+foreign import ccall "wrapper"
+   export_DllUnload :: (IO ()) -> IO (Ptr ())
+foreign import ccall "wrapper"
+   export_nullaryMeth :: (IO HRESULT) -> IO (Ptr ())
+
+foreign import ccall "wrapper"
+   export_dllGetClassObject :: (Ptr CLSID -> Ptr (IID a) -> Ptr (Ptr (IUnknown a)) -> IO HRESULT) -> IO (Ptr ())
+
+data RegHive
+ = HKEY_CLASSES_ROOT
+ | HKEY_CURRENT_USER
+ | HKEY_LOCAL_MACHINE
+ | HKEY_USERS
+ | HKEY_CURRENT_CONFIG
+   deriving ( Eq, Ord, Enum )
+
+regAddEntry :: RegHive
+	    -> String
+	    -> Maybe String
+	    -> IO ()
+regAddEntry hive path value = do
+   m_path  <- marshallString path
+   m_value <- marshallMaybe marshallString nullPtr value
+   hr      <- primRegAddEntry (fromEnum hive) m_path m_value
+   checkHR hr
+
+regRemoveEntry :: RegHive
+	       -> String
+	       -> String
+	       -> Bool
+	       -> IO ()
+regRemoveEntry hive path value removeKey = do
+   m_path  <- marshallString path
+   m_value <- marshallString value
+   let m_removeKey
+        | removeKey = (1::Int)
+        | otherwise = 0
+   hr      <- primRegRemoveEntry (fromEnum hive) m_path m_value m_removeKey
+   checkHR hr
+
+foreign import ccall "primRegAddEntry" 
+   primRegAddEntry :: Int -> Ptr String -> Ptr String -> IO HRESULT
+foreign import ccall "primRegRemoveEntry" 
+   primRegRemoveEntry :: Int -> Ptr String -> Ptr String -> Int -> IO HRESULT
+
+stdRegComponent :: ComponentInfo -> Bool -> String -> IO ()
+stdRegComponent info isInProc path = do
+   let clsid_path = "CLSID\\" ++ clsid_str
+       progid     = componentProgID info
+       vprogid    = componentVProgID info
+       clsid_str  = show (componentCLSID info)
+
+        -- Add CLSID\{clsid}\friendly name
+   regAddEntry HKEY_CLASSES_ROOT clsid_path (Just (componentName info))
+        -- Add CLSID\{clsid}\ProgID (if any.)
+   when (not (null progid)) (regAddEntry HKEY_CLASSES_ROOT (clsid_path++"\\ProgID") (Just progid))
+        -- Add CLSID\{clsid}\VersionIndependentProgID (if any.)
+   when (not (null vprogid)) (regAddEntry HKEY_CLASSES_ROOT (clsid_path++"\\VersionIndependentProgID") (Just vprogid))
+        -- Add CLSID\{clsid}\{Inproc,Local}Server32\path
+   regAddEntry HKEY_CLASSES_ROOT (clsid_path ++ (if isInProc then "\\InprocServer32" else "\\LocalServer32")) (Just path)
+
+      -- register the type library; we don't care if it fails, or not.
+   when (componentTLB info)
+        (catch (loadTypeLibEx path True{-register-} >>= \ p -> p # release >> return ())
+	       (\ _ -> return ()))
+
+	-- Add the ProgID entries
+
+   when (not (null progid))  (regAddEntry HKEY_CLASSES_ROOT (progid  ++ "\\CLSID") (Just clsid_str))
+   when (not (null vprogid)) (regAddEntry HKEY_CLASSES_ROOT (vprogid ++ "\\CLSID") (Just clsid_str))
+   when (not (null vprogid) && not (null progid))
+                             (regAddEntry HKEY_CLASSES_ROOT (progid ++ "\\CurVer") (Just vprogid))
+   return ()
+
+--The removal of entries isn't quite right
+
+stdUnRegComponent :: ComponentInfo -> Bool -> String -> IO ()
+stdUnRegComponent info isInProc path = do
+   let clsid_path = "CLSID\\" ++ clsid_str
+       progid     = componentProgID info
+       vprogid    = componentVProgID info
+       clsid_str  = show (componentCLSID info)
+
+        -- Remove CLSID\{clsid}\{Local,Inproc}Server32
+   regRemoveEntry HKEY_CLASSES_ROOT clsid_path (if isInProc then "InprocServer32" else "LocalServer32") True
+        -- Remove CLSID\{clsid}\VersionIndependentProgID (if any.)
+   when (not (null vprogid)) (regRemoveEntry HKEY_CLASSES_ROOT clsid_path "VersionIndependentProgID" True)
+        -- Remove CLSID\{clsid}\ProgID (if any.)
+   when (not (null progid)) (regRemoveEntry HKEY_CLASSES_ROOT clsid_path "ProgID" True)
+        -- Remove CLSID\{clsid}\friendly name
+   regRemoveEntry HKEY_CLASSES_ROOT "CLSID" clsid_str True
+
+	-- Remove the ProgID entries
+   when (not (null progid))  (regRemoveEntry HKEY_CLASSES_ROOT (progid  ++ "\\CLSID") clsid_str False)
+   when (not (null progid))  (regRemoveEntry HKEY_CLASSES_ROOT progid  "CLSID"  True)
+   when (not (null progid) && not (null vprogid)) 
+			     (regRemoveEntry HKEY_CLASSES_ROOT  progid "CurVer" True)
+   when (not (null vprogid)) (regRemoveEntry HKEY_CLASSES_ROOT (vprogid ++ "\\CLSID") clsid_str False)
+   when (not (null vprogid)) (regRemoveEntry HKEY_CLASSES_ROOT vprogid  "CLSID" True)
+   return ()
+ System/Win32/Com/Exception.hs view
@@ -0,0 +1,798 @@+{-# OPTIONS -#include "comPrim.h" #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Win32.Com.Exception
+-- 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
+--
+-- 'Com exception handling' \/ HRESULT manipulation in Haskell.
+-- 
+-----------------------------------------------------------------------------
+module System.Win32.Com.Exception where
+
+import System.Win32.Com.HDirect.HDirect hiding ( readFloat )
+import System.Win32.Com.Base
+import Data.Int
+import Data.Word
+import Data.Bits
+import Data.Dynamic
+import Data.Maybe ( isJust )
+{- BEGIN_GHC_ONLY
+import GHC.IOBase
+   END_GHC_ONLY -}
+import Numeric ( showHex )
+import IO
+import qualified Control.OldException as Control.Exception ( catch, ioErrors )
+
+check2HR :: HRESULT -> IO ()
+check2HR hr
+      | succeeded hr = return ()
+      | otherwise    = do
+	  dw <- getLastError
+	  coFailHR (word32ToInt32 dw)
+
+{- FALSE = 0, TRUE = -1 -}
+checkBool :: Int32 -> IO ()
+checkBool flg
+      | flg /=0      = return ()
+      | otherwise    = do
+	  dw <- getLastError
+	  coFailHR (word32ToInt32 dw)
+
+returnHR :: IO () -> IO HRESULT
+returnHR act = (do
+  act 
+  return s_OK)
+{- BEGIN_GHC_ONLY 
+    `Control.Exception.catch`
+      (\ ex -> 
+        case Control.Exception.ioErrors ex of
+	  Just i -> 
+	    case coGetErrorHR i of
+	      Just x  -> return x
+	      Nothing -> return failure
+	  Nothing -> return failure)
+   END_GHC_ONLY -}
+{- BEGIN_NOT_FOR_GHC -}
+     -- once we can assume that IOError == Exception on the
+     -- Hugs side, no need for this.
+    `IO.catch`
+    (\ ex -> 
+        case coGetErrorHR ex of
+	  Just x  -> return x
+	  Nothing -> return failure)
+{- END_NOT_FOR_GHC -}
+ where
+   -- better return codes could easily be imagined..
+  failure = e_FAIL
+
+isCoError        :: IOError -> Bool
+coGetErrorHR     :: IOError -> Maybe HRESULT
+coGetErrorString :: IOError -> String
+
+{- BEGIN_GHC_ONLY
+isCoError ioe = isJust (coGetErrorHR ioe)
+
+#if __GLASGOW_HASKELL__ >= 505
+coGetErrorHR (IOError _ (DynIOError d) _ _ _) = 
+#else
+coGetErrorHR (IOException (IOError _ (DynIOError d) _ _ _)) = 
+#endif
+  case fromDynamic d of
+    Just (ComError hr) -> Just hr
+    Nothing            -> Nothing
+coGetErrorHR _	= Nothing
+
+#if __GLASGOW_HASKELL__ >= 505
+coGetErrorString ioe@(IOError _ (DynIOError dyn) loc str _)
+#else
+coGetErrorString ioe@(IOException (IOError _ (DynIOError dyn) loc str _))
+#endif
+  = case (fromDynamic dyn) of
+       Just (ComError hr) -> str ++ showParen True (showHex (int32ToWord32 hr)) ""
+       Nothing            -> ioeGetErrorString ioe
+coGetErrorString ioe = ioeGetErrorString ioe
+   END_GHC_ONLY -}
+
+{- BEGIN_NOT_FOR_GHC -}
+
+userPrefix = "User error: "
+prefixLen  = length userPrefix + length coPrefix
+
+isCoError err         = (isUserError err)  &&
+                        (prefix == userPrefix ++ coPrefix)
+                      where
+                        prefix    = take prefixLen (ioeGetErrorString err)
+
+--ToDo: try to fish it out from the user string.
+coGetErrorHR _ = Nothing
+
+coGetErrorString e
+  | isCoError e    = drop prefixLen (ioeGetErrorString e)
+  | otherwise      = drop (length userPrefix) (ioeGetErrorString e)
+
+{- END_NOT_FOR_GHC -}
+
+printComError :: IOError -> IO ()
+printComError ioe = putStrLn (coGetErrorString ioe)
+
+hresultToString :: HRESULT -> IO String
+hresultToString = stringFromHR
+
+coAssert :: Bool -> String -> IO ()
+coAssert True msg    = return ()
+coAssert False msg   = coFail msg
+
+coOnFail :: IO a -> String -> IO a
+coOnFail io msg      = io 
+{- BEGIN_GHC_ONLY 
+    `Control.Exception.catch`
+    (\ err -> 
+       case Control.Exception.ioErrors err of
+         Just i  -> coFail (msg ++ ": " ++ (coGetErrorString i))
+	 Nothing -> coFail msg)
+   END_GHC_ONLY -}
+{- BEGIN_NOT_FOR_GHC -}
+    `IO.catch`
+    (\ err -> coFail (msg ++ ": " ++ (coGetErrorString err)))
+{- END_NOT_FOR_GHC -}
+
+coFail :: String -> IO a
+coFail = coFailWithHR e_FAIL 
+
+s_FALSE, s_OK :: HRESULT
+s_OK = 0
+s_FALSE = 1
+
+nOERROR :: HRESULT
+nOERROR = 0 
+
+nO_ERROR :: HRESULT
+nO_ERROR = 0
+
+sEVERITY_ERROR :: Int32
+sEVERITY_ERROR = 1 
+sEVERITY_SUCCESS :: Int32
+sEVERITY_SUCCESS = 0 
+
+succeeded :: HRESULT -> Bool
+succeeded hr = hr >=0
+
+winErrorToHR :: Int32 -> HRESULT
+winErrorToHR 0 = 0
+winErrorToHR x = (fACILITY_WIN32 `shiftL` 16) .|. (bit 31) .|. (x .&. 0xffff)
+
+hRESULT_CODE :: HRESULT -> Int32
+hRESULT_CODE hr = hr .&. (fromIntegral 0xffff)
+
+hRESULT_FACILITY :: HRESULT -> Int32
+hRESULT_FACILITY hr = (hr `shiftR` 16) .&. 0x1fff
+
+hRESULT_SEVERITY :: HRESULT -> Int32
+hRESULT_SEVERITY hr = (hr `shiftR` 31) .&. 0x1
+
+mkHRESULT :: Int32 -> Int32 -> Int32 -> HRESULT
+mkHRESULT sev fac code = 
+  word32ToInt32 (
+      ((int32ToWord32 sev) `shiftL` 31) .|. 
+      ((int32ToWord32 fac) `shiftL` 16) .|.
+      (int32ToWord32 code)
+     )
+
+
+cAT_E_CATIDNOEXIST :: HRESULT
+cAT_E_CATIDNOEXIST = word32ToInt32 (0x80040160 ::Word32)
+cAT_E_FIRST :: HRESULT
+cAT_E_FIRST = word32ToInt32 (0x80040160 ::Word32)
+cAT_E_LAST :: HRESULT
+cAT_E_LAST = word32ToInt32 (0x80040161 ::Word32)
+cAT_E_NODESCRIPTION :: HRESULT
+cAT_E_NODESCRIPTION = word32ToInt32 (0x80040161 ::Word32)
+cLASS_E_CLASSNOTAVAILABLE :: HRESULT
+cLASS_E_CLASSNOTAVAILABLE = word32ToInt32 (0x80040111 ::Word32)
+cLASS_E_NOAGGREGATION :: HRESULT
+cLASS_E_NOAGGREGATION = word32ToInt32 (0x80040110 ::Word32)
+cLASS_E_NOTLICENSED :: HRESULT
+cLASS_E_NOTLICENSED = word32ToInt32 (0x80040112 ::Word32)
+cO_E_ACCESSCHECKFAILED :: HRESULT
+cO_E_ACCESSCHECKFAILED = word32ToInt32 (0x80040207 ::Word32)
+cO_E_ACESINWRONGORDER :: HRESULT
+cO_E_ACESINWRONGORDER = word32ToInt32 (0x80040217 ::Word32)
+cO_E_ACNOTINITIALIZED :: HRESULT
+cO_E_ACNOTINITIALIZED = word32ToInt32 (0x8004021B ::Word32)
+cO_E_ALREADYINITIALIZED :: HRESULT
+cO_E_ALREADYINITIALIZED = word32ToInt32 (0x800401F1 ::Word32)
+cO_E_APPDIDNTREG :: HRESULT
+cO_E_APPDIDNTREG = word32ToInt32 (0x800401FE ::Word32)
+cO_E_APPNOTFOUND :: HRESULT
+cO_E_APPNOTFOUND = word32ToInt32 (0x800401F5 ::Word32)
+cO_E_APPSINGLEUSE :: HRESULT
+cO_E_APPSINGLEUSE = word32ToInt32 (0x800401F6 ::Word32)
+cO_E_BAD_PATH :: HRESULT
+cO_E_BAD_PATH = word32ToInt32 (0x80080004 ::Word32)
+cO_E_BAD_SERVER_NAME :: HRESULT
+cO_E_BAD_SERVER_NAME = word32ToInt32 (0x80004014 ::Word32)
+cO_E_CANTDETERMINECLASS :: HRESULT
+cO_E_CANTDETERMINECLASS = word32ToInt32 (0x800401F2 ::Word32)
+cO_E_CANT_REMOTE :: HRESULT
+cO_E_CANT_REMOTE = word32ToInt32 (0x80004013 ::Word32)
+cO_E_CLASSSTRING :: HRESULT
+cO_E_CLASSSTRING = word32ToInt32 (0x800401F3 ::Word32)
+cO_E_CLASS_CREATE_FAILED :: HRESULT
+cO_E_CLASS_CREATE_FAILED = word32ToInt32 (0x80080001 ::Word32)
+cO_E_CLSREG_INCONSISTENT :: HRESULT
+cO_E_CLSREG_INCONSISTENT = word32ToInt32 (0x8000401F ::Word32)
+cO_E_CONVERSIONFAILED :: HRESULT
+cO_E_CONVERSIONFAILED = word32ToInt32 (0x8004020B ::Word32)
+cO_E_CREATEPROCESS_FAILURE :: HRESULT
+cO_E_CREATEPROCESS_FAILURE = word32ToInt32 (0x80004018 ::Word32)
+cO_E_DECODEFAILED :: HRESULT
+cO_E_DECODEFAILED = word32ToInt32 (0x8004021A ::Word32)
+cO_E_DLLNOTFOUND :: HRESULT
+cO_E_DLLNOTFOUND = word32ToInt32 (0x800401F8 ::Word32)
+cO_E_ERRORINAPP :: HRESULT
+cO_E_ERRORINAPP = word32ToInt32 (0x800401F7 ::Word32)
+cO_E_ERRORINDLL :: HRESULT
+cO_E_ERRORINDLL = word32ToInt32 (0x800401F9 ::Word32)
+cO_E_EXCEEDSYSACLLIMIT :: HRESULT
+cO_E_EXCEEDSYSACLLIMIT = word32ToInt32 (0x80040216 ::Word32)
+cO_E_FAILEDTOCLOSEHANDLE :: HRESULT
+cO_E_FAILEDTOCLOSEHANDLE = word32ToInt32 (0x80040215 ::Word32)
+cO_E_FAILEDTOCREATEFILE :: HRESULT
+cO_E_FAILEDTOCREATEFILE = word32ToInt32 (0x80040214 ::Word32)
+cO_E_FAILEDTOGENUUID :: HRESULT
+cO_E_FAILEDTOGENUUID = word32ToInt32 (0x80040213 ::Word32)
+cO_E_FAILEDTOGETSECCTX :: HRESULT
+cO_E_FAILEDTOGETSECCTX = word32ToInt32 (0x80040201 ::Word32)
+cO_E_FAILEDTOGETTOKENINFO :: HRESULT
+cO_E_FAILEDTOGETTOKENINFO = word32ToInt32 (0x80040203 ::Word32)
+cO_E_FAILEDTOGETWINDIR :: HRESULT
+cO_E_FAILEDTOGETWINDIR = word32ToInt32 (0x80040211 ::Word32)
+cO_E_FAILEDTOIMPERSONATE :: HRESULT
+cO_E_FAILEDTOIMPERSONATE = word32ToInt32 (0x80040200 ::Word32)
+cO_E_FAILEDTOOPENPROCESSTOKEN :: HRESULT
+cO_E_FAILEDTOOPENPROCESSTOKEN = word32ToInt32 (0x80040219 ::Word32)
+cO_E_FAILEDTOOPENTHREADTOKEN :: HRESULT
+cO_E_FAILEDTOOPENTHREADTOKEN = word32ToInt32 (0x80040202 ::Word32)
+cO_E_FAILEDTOQUERYCLIENTBLANKET :: HRESULT
+cO_E_FAILEDTOQUERYCLIENTBLANKET = word32ToInt32 (0x80040205 ::Word32)
+cO_E_FAILEDTOSETDACL :: HRESULT
+cO_E_FAILEDTOSETDACL = word32ToInt32 (0x80040206 ::Word32)
+cO_E_FIRST :: HRESULT
+cO_E_FIRST = word32ToInt32 (0x800401F0 ::Word32)
+cO_E_IIDREG_INCONSISTENT :: HRESULT
+cO_E_IIDREG_INCONSISTENT = word32ToInt32 (0x80004020 ::Word32)
+cO_E_IIDSTRING :: HRESULT
+cO_E_IIDSTRING = word32ToInt32 (0x800401F4 ::Word32)
+cO_E_INCOMPATIBLESTREAMVERSION :: HRESULT
+cO_E_INCOMPATIBLESTREAMVERSION = word32ToInt32 (0x80040218 ::Word32)
+cO_E_INIT_CLASS_CACHE :: HRESULT
+cO_E_INIT_CLASS_CACHE = word32ToInt32 (0x80004009 ::Word32)
+cO_E_INIT_MEMORY_ALLOCATOR :: HRESULT
+cO_E_INIT_MEMORY_ALLOCATOR = word32ToInt32 (0x80004008 ::Word32)
+cO_E_INIT_ONLY_SINGLE_THREADED :: HRESULT
+cO_E_INIT_ONLY_SINGLE_THREADED = word32ToInt32 (0x80004012 ::Word32)
+cO_E_INIT_RPC_CHANNEL :: HRESULT
+cO_E_INIT_RPC_CHANNEL = word32ToInt32 (0x8000400A ::Word32)
+cO_E_INIT_SCM_EXEC_FAILURE :: HRESULT
+cO_E_INIT_SCM_EXEC_FAILURE = word32ToInt32 (0x80004011 ::Word32)
+cO_E_INIT_SCM_FILE_MAPPING_EXISTS :: HRESULT
+cO_E_INIT_SCM_FILE_MAPPING_EXISTS = word32ToInt32 (0x8000400F ::Word32)
+cO_E_INIT_SCM_MAP_VIEW_OF_FILE :: HRESULT
+cO_E_INIT_SCM_MAP_VIEW_OF_FILE = word32ToInt32 (0x80004010 ::Word32)
+cO_E_INIT_SCM_MUTEX_EXISTS :: HRESULT
+cO_E_INIT_SCM_MUTEX_EXISTS = word32ToInt32 (0x8000400E ::Word32)
+cO_E_INIT_SHARED_ALLOCATOR :: HRESULT
+cO_E_INIT_SHARED_ALLOCATOR = word32ToInt32 (0x80004007 ::Word32)
+cO_E_INIT_TLS :: HRESULT
+cO_E_INIT_TLS = word32ToInt32 (0x80004006 ::Word32)
+cO_E_INIT_TLS_CHANNEL_CONTROL :: HRESULT
+cO_E_INIT_TLS_CHANNEL_CONTROL = word32ToInt32 (0x8000400C ::Word32)
+cO_E_INIT_TLS_SET_CHANNEL_CONTROL :: HRESULT
+cO_E_INIT_TLS_SET_CHANNEL_CONTROL = word32ToInt32 (0x8000400B ::Word32)
+cO_E_INIT_UNACCEPTED_USER_ALLOCATOR :: HRESULT
+cO_E_INIT_UNACCEPTED_USER_ALLOCATOR = word32ToInt32 (0x8000400D ::Word32)
+cO_E_INVALIDSID :: HRESULT
+cO_E_INVALIDSID = word32ToInt32 (0x8004020A ::Word32)
+cO_E_LAST :: HRESULT
+cO_E_LAST = word32ToInt32 (0x800401FF ::Word32)
+cO_E_LAUNCH_PERMSSION_DENIED :: HRESULT
+cO_E_LAUNCH_PERMSSION_DENIED = word32ToInt32 (0x8000401B ::Word32)
+cO_E_LOOKUPACCNAMEFAILED :: HRESULT
+cO_E_LOOKUPACCNAMEFAILED = word32ToInt32 (0x8004020F ::Word32)
+cO_E_LOOKUPACCSIDFAILED :: HRESULT
+cO_E_LOOKUPACCSIDFAILED = word32ToInt32 (0x8004020D ::Word32)
+cO_E_MSI_ERROR :: HRESULT
+cO_E_MSI_ERROR = word32ToInt32 (0x80004023 ::Word32)
+cO_E_NETACCESSAPIFAILED :: HRESULT
+cO_E_NETACCESSAPIFAILED = word32ToInt32 (0x80040208 ::Word32)
+cO_E_NOMATCHINGNAMEFOUND :: HRESULT
+cO_E_NOMATCHINGNAMEFOUND = word32ToInt32 (0x8004020E ::Word32)
+cO_E_NOMATCHINGSIDFOUND :: HRESULT
+cO_E_NOMATCHINGSIDFOUND = word32ToInt32 (0x8004020C ::Word32)
+cO_E_NOTINITIALIZED :: HRESULT
+cO_E_NOTINITIALIZED = word32ToInt32 (0x800401F0 ::Word32)
+cO_E_NOT_SUPPORTED :: HRESULT
+cO_E_NOT_SUPPORTED = word32ToInt32 (0x80004021 ::Word32)
+cO_E_OBJISREG :: HRESULT
+cO_E_OBJISREG = word32ToInt32 (0x800401FC ::Word32)
+cO_E_OBJNOTCONNECTED :: HRESULT
+cO_E_OBJNOTCONNECTED = word32ToInt32 (0x800401FD ::Word32)
+cO_E_OBJNOTREG :: HRESULT
+cO_E_OBJNOTREG = word32ToInt32 (0x800401FB ::Word32)
+cO_E_OBJSRV_RPC_FAILURE :: HRESULT
+cO_E_OBJSRV_RPC_FAILURE = word32ToInt32 (0x80080006 ::Word32)
+cO_E_OLE1DDE_DISABLED :: HRESULT
+cO_E_OLE1DDE_DISABLED = word32ToInt32 (0x80004016 ::Word32)
+cO_E_PATHTOOLONG :: HRESULT
+cO_E_PATHTOOLONG = word32ToInt32 (0x80040212 ::Word32)
+cO_E_RELEASED :: HRESULT
+cO_E_RELEASED = word32ToInt32 (0x800401FF ::Word32)
+cO_E_RELOAD_DLL :: HRESULT
+cO_E_RELOAD_DLL = word32ToInt32 (0x80004022 ::Word32)
+cO_E_REMOTE_COMMUNICATION_FAILURE :: HRESULT
+cO_E_REMOTE_COMMUNICATION_FAILURE = word32ToInt32 (0x8000401D ::Word32)
+cO_E_RUNAS_CREATEPROCESS_FAILURE :: HRESULT
+cO_E_RUNAS_CREATEPROCESS_FAILURE = word32ToInt32 (0x80004019 ::Word32)
+cO_E_RUNAS_LOGON_FAILURE :: HRESULT
+cO_E_RUNAS_LOGON_FAILURE = word32ToInt32 (0x8000401A ::Word32)
+cO_E_RUNAS_SYNTAX :: HRESULT
+cO_E_RUNAS_SYNTAX = word32ToInt32 (0x80004017 ::Word32)
+cO_E_SCM_ERROR :: HRESULT
+cO_E_SCM_ERROR = word32ToInt32 (0x80080002 ::Word32)
+cO_E_SCM_RPC_FAILURE :: HRESULT
+cO_E_SCM_RPC_FAILURE = word32ToInt32 (0x80080003 ::Word32)
+cO_E_SERVER_EXEC_FAILURE :: HRESULT
+cO_E_SERVER_EXEC_FAILURE = word32ToInt32 (0x80080005 ::Word32)
+cO_E_SERVER_START_TIMEOUT :: HRESULT
+cO_E_SERVER_START_TIMEOUT = word32ToInt32 (0x8000401E ::Word32)
+cO_E_SERVER_STOPPING :: HRESULT
+cO_E_SERVER_STOPPING = word32ToInt32 (0x80080008 ::Word32)
+cO_E_SETSERLHNDLFAILED :: HRESULT
+cO_E_SETSERLHNDLFAILED = word32ToInt32 (0x80040210 ::Word32)
+cO_E_START_SERVICE_FAILURE :: HRESULT
+cO_E_START_SERVICE_FAILURE = word32ToInt32 (0x8000401C ::Word32)
+cO_E_TRUSTEEDOESNTMATCHCLIENT :: HRESULT
+cO_E_TRUSTEEDOESNTMATCHCLIENT = word32ToInt32 (0x80040204 ::Word32)
+cO_E_WRONGOSFORAPP :: HRESULT
+cO_E_WRONGOSFORAPP = word32ToInt32 (0x800401FA ::Word32)
+cO_E_WRONGTRUSTEENAMESYNTAX :: HRESULT
+cO_E_WRONGTRUSTEENAMESYNTAX = word32ToInt32 (0x80040209 ::Word32)
+cO_E_WRONG_SERVER_IDENTITY :: HRESULT
+cO_E_WRONG_SERVER_IDENTITY = word32ToInt32 (0x80004015 ::Word32)
+cO_S_FIRST :: HRESULT
+cO_S_FIRST = word32ToInt32 (0x000401F0 ::Word32)
+cO_S_LAST :: HRESULT
+cO_S_LAST = word32ToInt32 (0x000401FF ::Word32)
+cO_S_NOTALLINTERFACES :: HRESULT
+cO_S_NOTALLINTERFACES = word32ToInt32 (0x00080012 ::Word32)
+dISP_E_ARRAYISLOCKED :: HRESULT
+dISP_E_ARRAYISLOCKED = word32ToInt32 (0x8002000D ::Word32)
+dISP_E_BADCALLEE :: HRESULT
+dISP_E_BADCALLEE = word32ToInt32 (0x80020010 ::Word32)
+dISP_E_BADINDEX :: HRESULT
+dISP_E_BADINDEX = word32ToInt32 (0x8002000B ::Word32)
+dISP_E_BADPARAMCOUNT :: HRESULT
+dISP_E_BADPARAMCOUNT = word32ToInt32 (0x8002000E ::Word32)
+dISP_E_BADVARTYPE :: HRESULT
+dISP_E_BADVARTYPE = word32ToInt32 (0x80020008 ::Word32)
+dISP_E_DIVBYZERO :: HRESULT
+dISP_E_DIVBYZERO = word32ToInt32 (0x80020012 ::Word32)
+dISP_E_EXCEPTION :: HRESULT
+dISP_E_EXCEPTION = word32ToInt32 (0x80020009 ::Word32)
+dISP_E_MEMBERNOTFOUND :: HRESULT
+dISP_E_MEMBERNOTFOUND = word32ToInt32 (0x80020003 ::Word32)
+dISP_E_NONAMEDARGS :: HRESULT
+dISP_E_NONAMEDARGS = word32ToInt32 (0x80020007 ::Word32)
+dISP_E_NOTACOLLECTION :: HRESULT
+dISP_E_NOTACOLLECTION = word32ToInt32 (0x80020011 ::Word32)
+dISP_E_OVERFLOW :: HRESULT
+dISP_E_OVERFLOW = word32ToInt32 (0x8002000A ::Word32)
+dISP_E_PARAMNOTFOUND :: HRESULT
+dISP_E_PARAMNOTFOUND = word32ToInt32 (0x80020004 ::Word32)
+dISP_E_PARAMNOTOPTIONAL :: HRESULT
+dISP_E_PARAMNOTOPTIONAL = word32ToInt32 (0x8002000F ::Word32)
+dISP_E_TYPEMISMATCH :: HRESULT
+dISP_E_TYPEMISMATCH = word32ToInt32 (0x80020005 ::Word32)
+dISP_E_UNKNOWNINTERFACE :: HRESULT
+dISP_E_UNKNOWNINTERFACE = word32ToInt32 (0x80020001 ::Word32)
+dISP_E_UNKNOWNLCID :: HRESULT
+dISP_E_UNKNOWNLCID = word32ToInt32 (0x8002000C ::Word32)
+dISP_E_UNKNOWNNAME :: HRESULT
+dISP_E_UNKNOWNNAME = word32ToInt32 (0x80020006 ::Word32)
+dV_E_CLIPFORMAT :: HRESULT
+dV_E_CLIPFORMAT = word32ToInt32 (0x8004006A ::Word32)
+dV_E_DVASPECT :: HRESULT
+dV_E_DVASPECT = word32ToInt32 (0x8004006B ::Word32)
+dV_E_DVTARGETDEVICE :: HRESULT
+dV_E_DVTARGETDEVICE = word32ToInt32 (0x80040065 ::Word32)
+dV_E_DVTARGETDEVICE_SIZE :: HRESULT
+dV_E_DVTARGETDEVICE_SIZE = word32ToInt32 (0x8004006C ::Word32)
+dV_E_FORMATETC :: HRESULT
+dV_E_FORMATETC = word32ToInt32 (0x80040064 ::Word32)
+dV_E_LINDEX :: HRESULT
+dV_E_LINDEX = word32ToInt32 (0x80040068 ::Word32)
+dV_E_NOIVIEWOBJECT :: HRESULT
+dV_E_NOIVIEWOBJECT = word32ToInt32 (0x8004006D ::Word32)
+dV_E_STATDATA :: HRESULT
+dV_E_STATDATA = word32ToInt32 (0x80040067 ::Word32)
+dV_E_STGMEDIUM :: HRESULT
+dV_E_STGMEDIUM = word32ToInt32 (0x80040066 ::Word32)
+dV_E_TYMED :: HRESULT
+dV_E_TYMED = word32ToInt32 (0x80040069 ::Word32)
+e_ABORT :: HRESULT
+e_ABORT = word32ToInt32 (0x80004004 ::Word32)
+e_ACCESSDENIED :: HRESULT
+e_ACCESSDENIED = word32ToInt32 (0x80070005 ::Word32)
+e_FAIL :: HRESULT
+e_FAIL = word32ToInt32 (0x80004005 ::Word32)
+e_HANDLE :: HRESULT
+e_HANDLE = word32ToInt32 (0x80070006 ::Word32)
+e_INVALIDARG :: HRESULT
+e_INVALIDARG = word32ToInt32 (0x80070057 ::Word32)
+e_NOINTERFACE :: HRESULT
+e_NOINTERFACE = word32ToInt32 (0x80004002 ::Word32)
+e_NOTIMPL :: HRESULT
+e_NOTIMPL = word32ToInt32 (0x80004001 ::Word32)
+e_OUTOFMEMORY :: HRESULT
+e_OUTOFMEMORY = word32ToInt32 (0x8007000E ::Word32)
+e_PENDING :: HRESULT
+e_PENDING = word32ToInt32 (0x8000000A ::Word32)
+e_POINTER :: HRESULT
+e_POINTER = word32ToInt32 (0x80004003 ::Word32)
+e_UNEXPECTED :: HRESULT
+e_UNEXPECTED = word32ToInt32 (0x8000FFFF ::Word32)
+
+fACILITY_CERT :: HRESULT
+fACILITY_CERT = 11 
+fACILITY_CONTROL :: HRESULT
+fACILITY_CONTROL = 10 
+fACILITY_DISPATCH :: HRESULT
+fACILITY_DISPATCH = 2 
+fACILITY_INTERNET :: HRESULT
+fACILITY_INTERNET = 12 
+fACILITY_ITF :: HRESULT
+fACILITY_ITF = 4 
+fACILITY_MEDIASERVER :: HRESULT
+fACILITY_MEDIASERVER = 13 
+fACILITY_MSMQ :: HRESULT
+fACILITY_MSMQ = 14 
+fACILITY_NT_BIT :: HRESULT
+fACILITY_NT_BIT = word32ToInt32 (0x10000000 ::Word32)
+fACILITY_NULL :: HRESULT
+fACILITY_NULL = 0 
+fACILITY_RPC :: HRESULT
+fACILITY_RPC = 1 
+fACILITY_SETUPAPI :: HRESULT
+fACILITY_SETUPAPI = 15 
+fACILITY_SSPI :: HRESULT
+fACILITY_SSPI = 9 
+fACILITY_STORAGE :: HRESULT
+fACILITY_STORAGE = 3 
+fACILITY_WIN32 :: HRESULT
+fACILITY_WIN32 = 7 
+fACILITY_WINDOWS :: HRESULT
+fACILITY_WINDOWS = 8 
+
+iNPLACE_E_FIRST :: HRESULT
+iNPLACE_E_FIRST = word32ToInt32 (0x800401A0 ::Word32)
+iNPLACE_E_LAST :: HRESULT
+iNPLACE_E_LAST = word32ToInt32 (0x800401AF ::Word32)
+iNPLACE_E_NOTOOLSPACE :: HRESULT
+iNPLACE_E_NOTOOLSPACE = word32ToInt32 (0x800401A1 ::Word32)
+iNPLACE_E_NOTUNDOABLE :: HRESULT
+iNPLACE_E_NOTUNDOABLE = word32ToInt32 (0x800401A0 ::Word32)
+iNPLACE_S_FIRST :: HRESULT
+iNPLACE_S_FIRST = word32ToInt32 (0x000401A0 ::Word32)
+iNPLACE_S_LAST :: HRESULT
+iNPLACE_S_LAST = word32ToInt32 (0x000401AF ::Word32)
+iNPLACE_S_TRUNCATED :: HRESULT
+iNPLACE_S_TRUNCATED = word32ToInt32 (0x000401A0 ::Word32)
+
+mARSHAL_E_FIRST :: HRESULT
+mARSHAL_E_FIRST = word32ToInt32 (0x80040120 ::Word32)
+mARSHAL_E_LAST :: HRESULT
+mARSHAL_E_LAST = word32ToInt32 (0x8004012F ::Word32)
+mARSHAL_S_FIRST :: HRESULT
+mARSHAL_S_FIRST = word32ToInt32 (0x00040120 ::Word32)
+mARSHAL_S_LAST :: HRESULT
+mARSHAL_S_LAST = word32ToInt32 (0x0004012F ::Word32)
+
+mEM_E_INVALID_LINK :: HRESULT
+mEM_E_INVALID_LINK = word32ToInt32 (0x80080010 ::Word32)
+mEM_E_INVALID_ROOT :: HRESULT
+mEM_E_INVALID_ROOT = word32ToInt32 (0x80080009 ::Word32)
+mEM_E_INVALID_SIZE :: HRESULT
+mEM_E_INVALID_SIZE = word32ToInt32 (0x80080011 ::Word32)
+
+mK_E_CANTOPENFILE :: HRESULT
+mK_E_CANTOPENFILE = word32ToInt32 (0x800401EA ::Word32)
+mK_E_CONNECTMANUALLY :: HRESULT
+mK_E_CONNECTMANUALLY = word32ToInt32 (0x800401E0 ::Word32)
+mK_E_ENUMERATION_FAILED :: HRESULT
+mK_E_ENUMERATION_FAILED = word32ToInt32 (0x800401EF ::Word32)
+mK_E_EXCEEDEDDEADLINE :: HRESULT
+mK_E_EXCEEDEDDEADLINE = word32ToInt32 (0x800401E1 ::Word32)
+mK_E_FIRST :: HRESULT
+mK_E_FIRST = word32ToInt32 (0x800401E0 ::Word32)
+mK_E_INTERMEDIATEINTERFACENOTSUPPORTED :: HRESULT
+mK_E_INTERMEDIATEINTERFACENOTSUPPORTED = word32ToInt32 (0x800401E7 ::Word32)
+mK_E_INVALIDEXTENSION :: HRESULT
+mK_E_INVALIDEXTENSION = word32ToInt32 (0x800401E6 ::Word32)
+mK_E_LAST :: HRESULT
+mK_E_LAST = word32ToInt32 (0x800401EF ::Word32)
+mK_E_MUSTBOTHERUSER :: HRESULT
+mK_E_MUSTBOTHERUSER = word32ToInt32 (0x800401EB ::Word32)
+mK_E_NEEDGENERIC :: HRESULT
+mK_E_NEEDGENERIC = word32ToInt32 (0x800401E2 ::Word32)
+mK_E_NOINVERSE :: HRESULT
+mK_E_NOINVERSE = word32ToInt32 (0x800401EC ::Word32)
+mK_E_NOOBJECT :: HRESULT
+mK_E_NOOBJECT = word32ToInt32 (0x800401E5 ::Word32)
+mK_E_NOPREFIX :: HRESULT
+mK_E_NOPREFIX = word32ToInt32 (0x800401EE ::Word32)
+mK_E_NOSTORAGE :: HRESULT
+mK_E_NOSTORAGE = word32ToInt32 (0x800401ED ::Word32)
+mK_E_NOTBINDABLE :: HRESULT
+mK_E_NOTBINDABLE = word32ToInt32 (0x800401E8 ::Word32)
+mK_E_NOTBOUND :: HRESULT
+mK_E_NOTBOUND = word32ToInt32 (0x800401E9 ::Word32)
+mK_E_NO_NORMALIZED :: HRESULT
+mK_E_NO_NORMALIZED = word32ToInt32 (0x80080007 ::Word32)
+mK_E_SYNTAX :: HRESULT
+mK_E_SYNTAX = word32ToInt32 (0x800401E4 ::Word32)
+mK_E_UNAVAILABLE :: HRESULT
+mK_E_UNAVAILABLE = word32ToInt32 (0x800401E3 ::Word32)
+mK_S_FIRST :: HRESULT
+mK_S_FIRST = word32ToInt32 (0x000401E0 ::Word32)
+mK_S_HIM :: HRESULT
+mK_S_HIM = word32ToInt32 (0x000401E5 ::Word32)
+mK_S_LAST :: HRESULT
+mK_S_LAST = word32ToInt32 (0x000401EF ::Word32)
+mK_S_ME :: HRESULT
+mK_S_ME = word32ToInt32 (0x000401E4 ::Word32)
+mK_S_MONIKERALREADYREGISTERED :: HRESULT
+mK_S_MONIKERALREADYREGISTERED = word32ToInt32 (0x000401E7 ::Word32)
+mK_S_REDUCED_TO_SELF :: HRESULT
+mK_S_REDUCED_TO_SELF = word32ToInt32 (0x000401E2 ::Word32)
+mK_S_US :: HRESULT
+mK_S_US = word32ToInt32 (0x000401E6 ::Word32)
+
+oLEOBJ_E_FIRST :: HRESULT
+oLEOBJ_E_FIRST = word32ToInt32 (0x80040180 ::Word32)
+oLEOBJ_E_INVALIDVERB :: HRESULT
+oLEOBJ_E_INVALIDVERB = word32ToInt32 (0x80040181 ::Word32)
+oLEOBJ_E_LAST :: HRESULT
+oLEOBJ_E_LAST = word32ToInt32 (0x8004018F ::Word32)
+oLEOBJ_E_NOVERBS :: HRESULT
+oLEOBJ_E_NOVERBS = word32ToInt32 (0x80040180 ::Word32)
+oLEOBJ_S_CANNOT_DOVERB_NOW :: HRESULT
+oLEOBJ_S_CANNOT_DOVERB_NOW = word32ToInt32 (0x00040181 ::Word32)
+oLEOBJ_S_FIRST :: HRESULT
+oLEOBJ_S_FIRST = word32ToInt32 (0x00040180 ::Word32)
+oLEOBJ_S_INVALIDHWND :: HRESULT
+oLEOBJ_S_INVALIDHWND = word32ToInt32 (0x00040182 ::Word32)
+oLEOBJ_S_INVALIDVERB :: HRESULT
+oLEOBJ_S_INVALIDVERB = word32ToInt32 (0x00040180 ::Word32)
+oLEOBJ_S_LAST :: HRESULT
+oLEOBJ_S_LAST = word32ToInt32 (0x0004018F ::Word32)
+
+oLE_E_ADVF :: HRESULT
+oLE_E_ADVF = word32ToInt32 (0x80040001 ::Word32)
+oLE_E_ADVISENOTSUPPORTED :: HRESULT
+oLE_E_ADVISENOTSUPPORTED = word32ToInt32 (0x80040003 ::Word32)
+oLE_E_BLANK :: HRESULT
+oLE_E_BLANK = word32ToInt32 (0x80040007 ::Word32)
+oLE_E_CANTCONVERT :: HRESULT
+oLE_E_CANTCONVERT = word32ToInt32 (0x80040011 ::Word32)
+oLE_E_CANT_BINDTOSOURCE :: HRESULT
+oLE_E_CANT_BINDTOSOURCE = word32ToInt32 (0x8004000A ::Word32)
+oLE_E_CANT_GETMONIKER :: HRESULT
+oLE_E_CANT_GETMONIKER = word32ToInt32 (0x80040009 ::Word32)
+oLE_E_CLASSDIFF :: HRESULT
+oLE_E_CLASSDIFF = word32ToInt32 (0x80040008 ::Word32)
+oLE_E_ENUM_NOMORE :: HRESULT
+oLE_E_ENUM_NOMORE = word32ToInt32 (0x80040002 ::Word32)
+oLE_E_FIRST :: HRESULT
+oLE_E_FIRST = word32ToInt32 (0x80040000::Word32)
+oLE_E_INVALIDHWND :: HRESULT
+oLE_E_INVALIDHWND = word32ToInt32 (0x8004000F ::Word32)
+oLE_E_INVALIDRECT :: HRESULT
+oLE_E_INVALIDRECT = word32ToInt32 (0x8004000D ::Word32)
+oLE_E_LAST :: HRESULT
+oLE_E_LAST = word32ToInt32 (0x800400FF::Word32)
+oLE_E_NOCACHE :: HRESULT
+oLE_E_NOCACHE = word32ToInt32 (0x80040006 ::Word32)
+oLE_E_NOCONNECTION :: HRESULT
+oLE_E_NOCONNECTION = word32ToInt32 (0x80040004 ::Word32)
+oLE_E_NOSTORAGE :: HRESULT
+oLE_E_NOSTORAGE = word32ToInt32 (0x80040012 ::Word32)
+oLE_E_NOTRUNNING :: HRESULT
+oLE_E_NOTRUNNING = word32ToInt32 (0x80040005 ::Word32)
+oLE_E_NOT_INPLACEACTIVE :: HRESULT
+oLE_E_NOT_INPLACEACTIVE = word32ToInt32 (0x80040010 ::Word32)
+oLE_E_OLEVERB :: HRESULT
+oLE_E_OLEVERB = word32ToInt32 (0x80040000 ::Word32)
+oLE_E_PROMPTSAVECANCELLED :: HRESULT
+oLE_E_PROMPTSAVECANCELLED = word32ToInt32 (0x8004000C ::Word32)
+oLE_E_STATIC :: HRESULT
+oLE_E_STATIC = word32ToInt32 (0x8004000B ::Word32)
+oLE_E_WRONGCOMPOBJ :: HRESULT
+oLE_E_WRONGCOMPOBJ = word32ToInt32 (0x8004000E ::Word32)
+oLE_S_FIRST :: HRESULT
+oLE_S_FIRST = word32ToInt32 (0x00040000 ::Word32)
+oLE_S_LAST :: HRESULT
+oLE_S_LAST = word32ToInt32 (0x000400FF ::Word32)
+oLE_S_MAC_CLIPFORMAT :: HRESULT
+oLE_S_MAC_CLIPFORMAT = word32ToInt32 (0x00040002 ::Word32)
+oLE_S_STATIC :: HRESULT
+oLE_S_STATIC = word32ToInt32 (0x00040001 ::Word32)
+oLE_S_USEREG :: HRESULT
+oLE_S_USEREG = word32ToInt32 (0x00040000 ::Word32)
+
+pERSIST_E_NOTSELFSIZING :: HRESULT
+pERSIST_E_NOTSELFSIZING = word32ToInt32 (0x800B000B ::Word32)
+pERSIST_E_SIZEDEFINITE :: HRESULT
+pERSIST_E_SIZEDEFINITE = word32ToInt32 (0x800B0009 ::Word32)
+pERSIST_E_SIZEINDEFINITE :: HRESULT
+pERSIST_E_SIZEINDEFINITE = word32ToInt32 (0x800B000A ::Word32)
+
+sTG_E_ABNORMALAPIEXIT :: HRESULT
+sTG_E_ABNORMALAPIEXIT = word32ToInt32 (0x800300FA ::Word32)
+sTG_E_ACCESSDENIED :: HRESULT
+sTG_E_ACCESSDENIED = word32ToInt32 (0x80030005 ::Word32)
+sTG_E_BADBASEADDRESS :: HRESULT
+sTG_E_BADBASEADDRESS = word32ToInt32 (0x80030110 ::Word32)
+sTG_E_CANTSAVE :: HRESULT
+sTG_E_CANTSAVE = word32ToInt32 (0x80030103 ::Word32)
+sTG_E_DISKISWRITEPROTECTED :: HRESULT
+sTG_E_DISKISWRITEPROTECTED = word32ToInt32 (0x80030013 ::Word32)
+sTG_E_DOCFILECORRUPT :: HRESULT
+sTG_E_DOCFILECORRUPT = word32ToInt32 (0x80030109 ::Word32)
+sTG_E_EXTANTMARSHALLINGS :: HRESULT
+sTG_E_EXTANTMARSHALLINGS = word32ToInt32 (0x80030108 ::Word32)
+sTG_E_FILEALREADYEXISTS :: HRESULT
+sTG_E_FILEALREADYEXISTS = word32ToInt32 (0x80030050 ::Word32)
+sTG_E_FILENOTFOUND :: HRESULT
+sTG_E_FILENOTFOUND = word32ToInt32 (0x80030002 ::Word32)
+sTG_E_INCOMPLETE :: HRESULT
+sTG_E_INCOMPLETE = word32ToInt32 (0x80030201 ::Word32)
+sTG_E_INSUFFICIENTMEMORY :: HRESULT
+sTG_E_INSUFFICIENTMEMORY = word32ToInt32 (0x80030008 ::Word32)
+sTG_E_INUSE :: HRESULT
+sTG_E_INUSE = word32ToInt32 (0x80030100 ::Word32)
+sTG_E_INVALIDFLAG :: HRESULT
+sTG_E_INVALIDFLAG = word32ToInt32 (0x800300FF ::Word32)
+sTG_E_INVALIDFUNCTION :: HRESULT
+sTG_E_INVALIDFUNCTION = word32ToInt32 (0x80030001 ::Word32)
+sTG_E_INVALIDHANDLE :: HRESULT
+sTG_E_INVALIDHANDLE = word32ToInt32 (0x80030006 ::Word32)
+sTG_E_INVALIDHEADER :: HRESULT
+sTG_E_INVALIDHEADER = word32ToInt32 (0x800300FB ::Word32)
+sTG_E_INVALIDNAME :: HRESULT
+sTG_E_INVALIDNAME = word32ToInt32 (0x800300FC ::Word32)
+sTG_E_INVALIDPARAMETER :: HRESULT
+sTG_E_INVALIDPARAMETER = word32ToInt32 (0x80030057 ::Word32)
+sTG_E_INVALIDPOINTER :: HRESULT
+sTG_E_INVALIDPOINTER = word32ToInt32 (0x80030009 ::Word32)
+sTG_E_LOCKVIOLATION :: HRESULT
+sTG_E_LOCKVIOLATION = word32ToInt32 (0x80030021 ::Word32)
+sTG_E_MEDIUMFULL :: HRESULT
+sTG_E_MEDIUMFULL = word32ToInt32 (0x80030070 ::Word32)
+sTG_E_NOMOREFILES :: HRESULT
+sTG_E_NOMOREFILES = word32ToInt32 (0x80030012 ::Word32)
+sTG_E_NOTCURRENT :: HRESULT
+sTG_E_NOTCURRENT = word32ToInt32 (0x80030101 ::Word32)
+sTG_E_NOTFILEBASEDSTORAGE :: HRESULT
+sTG_E_NOTFILEBASEDSTORAGE = word32ToInt32 (0x80030107 ::Word32)
+sTG_E_OLDDLL :: HRESULT
+sTG_E_OLDDLL = word32ToInt32 (0x80030105 ::Word32)
+sTG_E_OLDFORMAT :: HRESULT
+sTG_E_OLDFORMAT = word32ToInt32 (0x80030104 ::Word32)
+sTG_E_PATHNOTFOUND :: HRESULT
+sTG_E_PATHNOTFOUND = word32ToInt32 (0x80030003 ::Word32)
+sTG_E_PROPSETMISMATCHED :: HRESULT
+sTG_E_PROPSETMISMATCHED = word32ToInt32 (0x800300F0 ::Word32)
+sTG_E_READFAULT :: HRESULT
+sTG_E_READFAULT = word32ToInt32 (0x8003001E ::Word32)
+sTG_E_REVERTED :: HRESULT
+sTG_E_REVERTED = word32ToInt32 (0x80030102 ::Word32)
+sTG_E_SEEKERROR :: HRESULT
+sTG_E_SEEKERROR = word32ToInt32 (0x80030019 ::Word32)
+sTG_E_SHAREREQUIRED :: HRESULT
+sTG_E_SHAREREQUIRED = word32ToInt32 (0x80030106 ::Word32)
+sTG_E_SHAREVIOLATION :: HRESULT
+sTG_E_SHAREVIOLATION = word32ToInt32 (0x80030020 ::Word32)
+sTG_E_TERMINATED :: HRESULT
+sTG_E_TERMINATED = word32ToInt32 (0x80030202 ::Word32)
+sTG_E_TOOMANYOPENFILES :: HRESULT
+sTG_E_TOOMANYOPENFILES = word32ToInt32 (0x80030004 ::Word32)
+sTG_E_UNIMPLEMENTEDFUNCTION :: HRESULT
+sTG_E_UNIMPLEMENTEDFUNCTION = word32ToInt32 (0x800300FE ::Word32)
+sTG_E_UNKNOWN :: HRESULT
+sTG_E_UNKNOWN = word32ToInt32 (0x800300FD ::Word32)
+sTG_E_WRITEFAULT :: HRESULT
+sTG_E_WRITEFAULT = word32ToInt32 (0x8003001D ::Word32)
+sTG_S_BLOCK :: HRESULT
+sTG_S_BLOCK = word32ToInt32 (0x00030201 ::Word32)
+sTG_S_CANNOTCONSOLIDATE :: HRESULT
+sTG_S_CANNOTCONSOLIDATE = word32ToInt32 (0x00030206 ::Word32)
+sTG_S_CONSOLIDATIONFAILED :: HRESULT
+sTG_S_CONSOLIDATIONFAILED = word32ToInt32 (0x00030205 ::Word32)
+sTG_S_CONVERTED :: HRESULT
+sTG_S_CONVERTED = word32ToInt32 (0x00030200 ::Word32)
+sTG_S_MONITORING :: HRESULT
+sTG_S_MONITORING = word32ToInt32 (0x00030203 ::Word32)
+sTG_S_MULTIPLEOPENS :: HRESULT
+sTG_S_MULTIPLEOPENS = word32ToInt32 (0x00030204 ::Word32)
+sTG_S_RETRYNOW :: HRESULT
+sTG_S_RETRYNOW = word32ToInt32 (0x00030202 ::Word32)
+
+tYPE_E_AMBIGUOUSNAME :: HRESULT
+tYPE_E_AMBIGUOUSNAME = word32ToInt32 (0x8002802C ::Word32)
+tYPE_E_BADMODULEKIND :: HRESULT
+tYPE_E_BADMODULEKIND = word32ToInt32 (0x800288BD ::Word32)
+tYPE_E_BUFFERTOOSMALL :: HRESULT
+tYPE_E_BUFFERTOOSMALL = word32ToInt32 (0x80028016 ::Word32)
+tYPE_E_CANTCREATETMPFILE :: HRESULT
+tYPE_E_CANTCREATETMPFILE = word32ToInt32 (0x80028CA3 ::Word32)
+tYPE_E_CANTLOADLIBRARY :: HRESULT
+tYPE_E_CANTLOADLIBRARY = word32ToInt32 (0x80029C4A ::Word32)
+tYPE_E_CIRCULARTYPE :: HRESULT
+tYPE_E_CIRCULARTYPE = word32ToInt32 (0x80029C84 ::Word32)
+tYPE_E_DLLFUNCTIONNOTFOUND :: HRESULT
+tYPE_E_DLLFUNCTIONNOTFOUND = word32ToInt32 (0x8002802F ::Word32)
+tYPE_E_DUPLICATEID :: HRESULT
+tYPE_E_DUPLICATEID = word32ToInt32 (0x800288C6 ::Word32)
+tYPE_E_ELEMENTNOTFOUND :: HRESULT
+tYPE_E_ELEMENTNOTFOUND = word32ToInt32 (0x8002802B ::Word32)
+tYPE_E_FIELDNOTFOUND :: HRESULT
+tYPE_E_FIELDNOTFOUND = word32ToInt32 (0x80028017 ::Word32)
+tYPE_E_INCONSISTENTPROPFUNCS :: HRESULT
+tYPE_E_INCONSISTENTPROPFUNCS = word32ToInt32 (0x80029C83 ::Word32)
+tYPE_E_INVALIDID :: HRESULT
+tYPE_E_INVALIDID = word32ToInt32 (0x800288CF ::Word32)
+tYPE_E_INVALIDSTATE :: HRESULT
+tYPE_E_INVALIDSTATE = word32ToInt32 (0x80028029 ::Word32)
+tYPE_E_INVDATAREAD :: HRESULT
+tYPE_E_INVDATAREAD = word32ToInt32 (0x80028018 ::Word32)
+tYPE_E_IOERROR :: HRESULT
+tYPE_E_IOERROR = word32ToInt32 (0x80028CA2 ::Word32)
+tYPE_E_LIBNOTREGISTERED :: HRESULT
+tYPE_E_LIBNOTREGISTERED = word32ToInt32 (0x8002801D ::Word32)
+tYPE_E_NAMECONFLICT :: HRESULT
+tYPE_E_NAMECONFLICT = word32ToInt32 (0x8002802D ::Word32)
+tYPE_E_OUTOFBOUNDS :: HRESULT
+tYPE_E_OUTOFBOUNDS = word32ToInt32 (0x80028CA1 ::Word32)
+tYPE_E_QUALIFIEDNAMEDISALLOWED :: HRESULT
+tYPE_E_QUALIFIEDNAMEDISALLOWED = word32ToInt32 (0x80028028 ::Word32)
+tYPE_E_REGISTRYACCESS :: HRESULT
+tYPE_E_REGISTRYACCESS = word32ToInt32 (0x8002801C ::Word32)
+tYPE_E_SIZETOOBIG :: HRESULT
+tYPE_E_SIZETOOBIG = word32ToInt32 (0x800288C5 ::Word32)
+tYPE_E_TYPEMISMATCH :: HRESULT
+tYPE_E_TYPEMISMATCH = word32ToInt32 (0x80028CA0 ::Word32)
+tYPE_E_UNDEFINEDTYPE :: HRESULT
+tYPE_E_UNDEFINEDTYPE = word32ToInt32 (0x80028027 ::Word32)
+tYPE_E_UNKNOWNLCID :: HRESULT
+tYPE_E_UNKNOWNLCID = word32ToInt32 (0x8002802E ::Word32)
+tYPE_E_UNSUPFORMAT :: HRESULT
+tYPE_E_UNSUPFORMAT = word32ToInt32 (0x80028019 ::Word32)
+tYPE_E_WRONGTYPEKIND :: HRESULT
+tYPE_E_WRONGTYPEKIND = word32ToInt32 (0x8002802A ::Word32)
+vIEW_E_DRAW :: HRESULT
+vIEW_E_DRAW = word32ToInt32 (0x80040140 ::Word32)
+vIEW_E_FIRST :: HRESULT
+vIEW_E_FIRST = word32ToInt32 (0x80040140 ::Word32)
+vIEW_E_LAST :: HRESULT
+vIEW_E_LAST = word32ToInt32 (0x8004014F ::Word32)
+vIEW_S_ALREADY_FROZEN :: HRESULT
+vIEW_S_ALREADY_FROZEN = word32ToInt32 (0x00040140 ::Word32)
+vIEW_S_FIRST :: HRESULT
+vIEW_S_FIRST = word32ToInt32 (0x00040140 ::Word32)
+vIEW_S_LAST :: HRESULT
+vIEW_S_LAST = word32ToInt32 (0x0004014F ::Word32)
+ System/Win32/Com/HDirect/HDirect.hs view
@@ -0,0 +1,1097 @@+{-# OPTIONS -#include "PointerSrc.h" #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Win32.Com.HDirect.HDirect
+-- Copyright   :  (c) Sigbjorn Finne, sof@dcs.gla.ac.uk 1999
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+-- 
+-- Maintainer  :  sof@galois.com
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- Stubs for marshalling and unmarshalling primitive types, as used
+-- by HaskellDirect-generated code.
+-- 
+-----------------------------------------------------------------------------
+module System.Win32.Com.HDirect.HDirect 
+	(
+	  module System.Win32.Com.HDirect.HDirect
+
+	, Int8
+	, Int16
+	, Int32
+	, Int64
+
+	, Word8
+	, Word16
+	, Word32
+	, Word64
+
+	, Char
+	, Double
+	, Float
+	, Bool
+	
+	, Ptr
+
+	, StablePtr
+	, deRefStablePtr
+	, free
+	
+	) where
+
+import Data.Char
+import Data.Int  ( Int8, Int16, Int32, Int64 )
+import Data.Word ( Word8, Word16, Word32, Word64 )
+import Control.Monad
+import System.Win32.Com.HDirect.Pointer
+import System.IO.Unsafe ( unsafePerformIO )
+
+
+import Foreign.StablePtr
+import Foreign.Storable
+import Foreign.ForeignPtr
+import Foreign.Ptr
+import Foreign.C.Types ( CChar )
+import Foreign.C.String
+import Foreign.Marshal.Alloc (mallocBytes, free)
+
+import Data.Bits
+{- BEGIN_GHC_ONLY
+#if __GLASGOW_HASKELL__ >= 505
+import GHC.Base ( Int(..), Int#, getTag )
+#else
+import GlaExts ( Int(..), Int#, dataToTag# )
+getTag :: a -> Int#
+getTag x = dataToTag# x
+{- WAS: x `seq` dataToTag# x
+        this won't work 
+	  (seq's type is a->b->b, where b isn't 'open',
+           but has to be of kind *)
+-}
+#endif
+   END_GHC_ONLY -}
+
+infixl 5 .+.
+
+{- BEGIN_GHC_ONLY
+#if __GLASGOW_HASKELL__ >= 601
+foreignPtrToPtr = unsafeForeignPtrToPtr
+#endif
+   END_GHC_ONLY -}
+{- BEGIN_NOT_FOR_GHC -}
+-- Versionitis. If your version of Hugs is troubled by this one, simply comment it out.
+foreignPtrToPtr = unsafeForeignPtrToPtr
+{- END_NOT_FOR_GHC -}
+
+{-
+At the moment the IDL compiler will emit calls to types with identity marshallers
+(i.e., by-value marshallers for primitive, FFI-recognised types), so we need
+to provide stubs for these here.
+-}
+
+--Int* marshalling functions:
+
+marshallInt :: Int -> IO Int
+marshallInt x = return x
+
+unmarshallInt :: Int -> IO Int
+unmarshallInt x = return x
+
+writeInt :: Ptr Int -> Int -> IO ()
+writeInt ptr v = poke ptr v
+
+readInt :: Ptr Int -> IO Int
+readInt ptr = peek ptr
+
+--ToDo: generate host-specific versions of 
+sizeofInt :: Word32
+sizeofInt = fromIntegral (sizeOf (0 :: Int))
+
+--Int8
+marshallInt8 :: Int8 -> IO Int8
+marshallInt8 v = return v
+
+unmarshallInt8 :: Int8 -> IO Int8
+unmarshallInt8 v = return v
+
+writeInt8 :: Ptr Int8 -> Int8 -> IO ()
+writeInt8 ptr v = poke ptr v
+
+readInt8 :: Ptr Int8 -> IO Int8
+readInt8 ptr = peek ptr
+
+sizeofInt8 :: Word32
+sizeofInt8 = fromIntegral (sizeOf (1 :: Int8))
+
+--Int16
+marshallInt16 :: Int16 -> IO Int16
+marshallInt16 x = return x
+unmarshallInt16 :: Int16 -> IO Int16
+unmarshallInt16 x = return x
+
+writeInt16 :: Ptr Int16 -> Int16 -> IO ()
+writeInt16 ptr v = poke ptr v
+
+readInt16 :: Ptr Int16 -> IO Int16
+readInt16 ptr = peek ptr
+
+sizeofInt16 :: Word32
+sizeofInt16 = fromIntegral (sizeOf (0 :: Int16))
+
+-- Int32
+marshallInt32 :: Int32 -> IO Int32
+marshallInt32 x = return x
+
+unmarshallInt32 :: Int32 -> IO Int32
+unmarshallInt32 x = return x
+
+writeInt32 :: Ptr Int32 -> Int32 -> IO ()
+writeInt32 ptr v = poke ptr v
+
+readInt32 :: Ptr Int32 -> IO Int32
+readInt32 ptr = peek ptr
+
+sizeofInt32 :: Word32
+sizeofInt32 = fromIntegral (sizeOf (0::Int32))
+
+marshallInt64 :: Int64 -> IO Int64
+marshallInt64 x = return x
+
+unmarshallInt64 :: Int64 -> IO Int64
+unmarshallInt64 x = return x
+
+writeInt64 :: Ptr Int64 -> Int64 -> IO ()
+readInt64 :: Ptr Int64 -> IO Int64
+writeInt64 ptr v = poke ptr v
+readInt64 ptr = peek ptr
+{-
+{- BEGIN_NOT_FOR_GHC -}
+writeInt64 ptr v = writeI64 ptr (fromIntegral lo) (fromIntegral hi)
+ where
+   (hi,lo) = (fromIntegral v) `divMod` (toInteger (maxBound :: Int) + 1)
+readInt64 ptr = do
+  px <- readI64 ptr
+  lo <- peekElemOff px 0
+  hi <- peekElemOff px 1
+  free ptr
+  return (fromIntegral ((toInteger lo) + (toInteger hi) * (toInteger (maxBound :: Int) + 1)))
+{- END_NOT_FOR_GHC -}
+-}
+
+sizeofInt64 :: Word32
+sizeofInt64 = fromIntegral (sizeOf (0 :: Int64))
+
+type Hyper   = Int64
+marshallHyper :: Hyper -> IO Int64
+unmarshallHyper :: Int64 -> IO Hyper
+writeHyper :: Ptr Hyper -> Hyper -> IO ()
+readHyper :: Ptr Hyper -> IO Hyper
+sizeofHyper :: Word32
+
+marshallHyper   = marshallInt64
+unmarshallHyper = unmarshallInt64
+writeHyper      = writeInt64
+readHyper       = readInt64
+sizeofHyper     = fromIntegral (sizeOf (0 :: Int64))
+
+writeInteger :: Ptr Integer -> Integer -> IO ()
+writeInteger ptr x = writeInt64 (castPtr ptr) (fromIntegral x)
+
+readInteger :: Ptr Integer -> IO Integer
+readInteger ptr = do
+  x <- readInt64 (castPtr ptr)
+  return (fromIntegral x)
+
+marshallInteger :: Integer -> IO (Int32, Int32)
+marshallInteger i =  return (fromInteger lo, fromInteger hi)
+ where
+   (hi,lo) = i `divMod` (toInteger (maxBound :: Int) + 1)
+
+unmarshallInteger :: (Int32,Int32) -> IO Integer
+unmarshallInteger (hi,lo) =  return ((toInteger lo) + (toInteger hi) * (toInteger (maxBound :: Int) + 1))
+
+marshallUInteger :: Integer -> IO (Int32, Int32)
+marshallUInteger = marshallInteger
+
+unmarshallUInteger :: (Int32,Int32) -> IO Integer
+unmarshallUInteger = unmarshallInteger
+
+readUInteger :: Ptr Integer -> IO Integer
+readUInteger = readInteger
+
+writeUInteger :: Ptr Integer -> Integer -> IO ()
+writeUInteger = writeInteger
+
+--Characters and bytes:
+--
+-- NOTE: we assume that Char is CChar (==an 8-bit byte.)
+
+marshallChar :: Char -> IO Char
+marshallChar x = return x
+
+unmarshallChar :: Char -> IO Char
+unmarshallChar x = return x
+
+writeChar :: Ptr Char -> Char -> IO ()
+writeChar ptr v = poke ((castPtr ptr) :: Ptr CChar) (castCharToCChar v)
+
+readChar :: Ptr Char -> IO Char
+readChar ptr = peek ((castPtr ptr) :: Ptr CChar) >>= return.castCCharToChar
+
+sizeofChar :: Word32
+sizeofChar     = fromIntegral (sizeOf (undefined :: CChar))
+
+-- wide chars.
+type Wchar_t = Word16
+
+marshallWchar_t :: Wchar_t -> IO Wchar_t
+marshallWchar_t   = marshallWord16
+unmarshallWchar_t :: Wchar_t -> IO Wchar_t
+unmarshallWchar_t = unmarshallWord16
+writeWchar_t :: Ptr Wchar_t -> Wchar_t -> IO ()
+writeWchar_t      = writeWord16
+readWchar_t :: Ptr Wchar_t -> IO Wchar_t
+readWchar_t       = readWord16
+sizeofWchar_t :: Word32
+sizeofWchar_t     = fromIntegral (sizeOf (0::Word16))
+
+
+type Octet   = Byte
+type Byte    = Word8
+
+marshallByte :: Byte -> IO Byte
+marshallByte   = marshallWord8
+unmarshallByte :: Byte -> IO Byte
+unmarshallByte = unmarshallWord8
+writeByte :: Ptr Byte -> Byte -> IO ()
+writeByte      = writeWord8
+readByte :: Ptr Byte -> IO Byte
+readByte       = readWord8
+sizeofByte :: Word32
+sizeofByte     = fromIntegral (sizeOf (0::Word8))
+
+--Words:
+
+-- Word8:
+marshallWord8 :: Word8 -> IO Word8
+marshallWord8 x = return x
+
+unmarshallWord8 :: Word8 -> IO Word8
+unmarshallWord8 x = return x
+
+writeWord8 :: Ptr Word8 -> Word8 -> IO ()
+writeWord8 ptr v = poke ptr v
+
+readWord8 :: Ptr Word8 -> IO Word8
+readWord8 ptr = peek ptr
+
+sizeofWord8 :: Word32
+sizeofWord8 = fromIntegral (sizeOf (undefined :: Word8))
+
+-- Word16:
+marshallWord16 :: Word16 -> IO Word16
+marshallWord16 x = return x
+
+unmarshallWord16 :: Word16 -> IO Word16
+unmarshallWord16 x = return x
+
+writeWord16 :: Ptr Word16 -> Word16 -> IO ()
+writeWord16 ptr v = poke ptr v
+
+readWord16 :: Ptr Word16 -> IO Word16
+readWord16 ptr = peek ptr
+
+sizeofWord16 :: Word32
+sizeofWord16 = fromIntegral (sizeOf (undefined :: Word16))
+
+-- Word32:
+marshallWord32 :: Word32 -> IO Word32
+marshallWord32 x = return x
+
+unmarshallWord32 :: Word32 -> IO Word32
+unmarshallWord32 x = return x
+
+writeWord32 :: Ptr Word32 -> Word32 -> IO ()
+writeWord32 ptr v = poke ptr v
+
+readWord32 :: Ptr Word32 -> IO Word32
+readWord32 ptr = peek ptr
+
+sizeofWord32 :: Word32
+sizeofWord32 = fromIntegral (sizeOf (undefined :: Word32))
+
+marshallWord64 :: Word64 -> IO Word64
+marshallWord64 x = return x
+
+unmarshallWord64 :: Word64 -> IO Word64
+unmarshallWord64 x = return x
+
+writeWord64 :: Ptr Word64 -> Word64 -> IO ()
+readWord64 :: Ptr Word64 -> IO Word64
+{- BEGIN_NOT_FOR_GHC -}
+writeWord64 _ _ = undefined
+readWord64 _ = undefined
+{- END_NOT_FOR_GHC -}
+{- BEGIN_GHC_ONLY
+writeWord64 p v = poke p v
+readWord64 p = peek p
+   END_GHC_ONLY -}
+
+sizeofWord64 :: Word32
+sizeofWord64 = fromIntegral (sizeOf (undefined :: Word64))
+
+
+--Addr marshallers:
+{-
+begin{code}
+marshallAddr :: Ptr Addr -> IO Addr
+marshallAddr p = return p
+
+unmarshallAddr :: Ptr Addr -> IO Addr
+unmarshallAddr p = return p
+
+writeAddr :: Ptr Addr -> Addr -> IO ()
+{- BEGIN_DEBUG
+writeAddr ptr a | ptr == nullAddr = ioError (userError "writeAddr: NULL pointer")
+   END_DEBUG -}
+writeAddr ptr a = writeAddrOffAddr ptr 0 a
+
+readAddr :: Ptr Addr -> IO Addr
+readAddr a = readAddrOffAddr a 0
+
+sizeofAddr :: Word32
+sizeofAddr     = fromIntegral (sizeOf (undefined :: Foreign.Ptr.Ptr ()))
+
+freeAddr :: Addr -> IO ()
+freeAddr = free
+end{code}
+-}
+
+--Double marshallers:
+
+marshallDouble :: Double -> IO Double
+marshallDouble x = return x
+
+unmarshallDouble :: Double -> IO Double
+unmarshallDouble x = return x
+
+writeDouble :: Ptr Double -> Double -> IO ()
+writeDouble ptr x = poke ptr x
+
+readDouble :: Ptr Double -> IO Double
+readDouble ptr = peek ptr
+
+sizeofDouble :: Word32
+sizeofDouble   = fromIntegral (sizeOf (undefined :: Double))
+
+writeFloat :: Ptr Float -> Float -> IO ()
+writeFloat ptr x = poke ptr x
+
+readFloat :: Ptr Float -> IO Float
+readFloat ptr = peek ptr
+
+sizeofFloat :: Word32
+sizeofFloat   = fromIntegral (sizeOf (undefined :: Float))
+
+
+--Booleans - represented externally by a long (Int32):
+
+marshallBool :: Bool -> IO Int32
+marshallBool v = marshallInt32 (if v then (-1) else 0)
+
+unmarshallBool :: Int32 -> IO Bool
+unmarshallBool v = return (v /= 0)
+
+writeBool :: Ptr Bool -> Bool -> IO ()
+writeBool ptr v = writeInt32 (castPtr ptr) (if v then (-1) else 0)
+
+readBool :: Ptr Bool -> IO Bool
+readBool ptr = do
+  v <- readInt32 (castPtr ptr)
+  return ( v /= 0 )
+
+sizeofBool :: Word32
+sizeofBool = fromIntegral (sizeOf (0 :: Int32))
+
+addNCastPtr :: Ptr a -> Word32 -> Ptr b
+addNCastPtr v off = v `plusPtr` (fromIntegral off)
+
+derefPtr :: Ptr (Ptr a) -> IO (Ptr a)
+derefPtr p = peek p
+
+indexPtr :: Ptr (Ptr a) -> Int -> IO (Ptr a)
+indexPtr p off = peekElemOff p off
+
+--The unit of allocation is an 8-bit byte.
+
+allocOutPtr :: IO (Ptr a)
+allocOutPtr = alloc 4 -- 4 bytes in a pointer. ToDo: 64-bit platform'ify.
+
+allocBytes :: Int -> IO (Ptr a)
+allocBytes len = alloc (fromIntegral len)
+
+allocWords :: Int -> IO (Ptr a)
+allocWords len = alloc (4 * fromIntegral len)
+
+
+alloc :: Word32 -> IO (Ptr a)
+alloc s = mallocBytes (fromIntegral s)
+
+doThenFree ::(Ptr a -> IO ()) -> (Ptr b -> IO c) -> Ptr d -> IO c
+doThenFree f act ptr = do
+   v <- act (castPtr ptr)
+   f (castPtr ptr)
+   return v
+
+trivialFree :: a -> IO ()
+trivialFree _ = return ()
+
+fillIn :: Int -> (Ptr a -> IO ()) -> IO (Ptr a)
+fillIn sz refreemarshall = do
+  ptr <- allocBytes sz
+  refreemarshall ptr
+  return ptr
+
+--[ptr]Ptr marshalling
+
+marshallPtr :: Ptr a -> IO (Ptr a)
+marshallPtr v = return v
+
+unmarshallPtr :: Ptr a -> IO (Ptr a)
+unmarshallPtr v = return v
+
+writePtr :: Ptr (Ptr a) -> Ptr a -> IO ()
+writePtr a v = poke a v
+
+readPtr :: Ptr a -> IO (Ptr b)
+readPtr a = peek (castPtr a)
+
+writefptr :: Ptr b -> ForeignPtr a -> IO ()
+writefptr p v = poke (castPtr p) (foreignPtrToPtr v)
+
+--[unique]Ptr marshalling
+
+marshallunique :: (IO (Ptr a))
+               -> (Ptr a -> a -> IO ())
+	       -> Maybe a
+	       -> IO (Ptr a)
+marshallunique allocRef marshallInto mb = 
+  case mb of
+    Nothing -> return nullPtr
+    Just x  -> marshallref allocRef marshallInto x
+
+marshallMaybe :: (a -> IO b) -> b -> Maybe a -> IO b
+marshallMaybe _mshall def  Nothing  = return def
+marshallMaybe mshall  _def (Just x) = mshall x
+
+writeMaybe :: (Ptr a -> a -> IO ())
+           -> Ptr (Maybe a)
+	   -> Maybe a
+	   -> IO ()
+writeMaybe _  ptr Nothing  = writePtr (castPtr ptr) nullPtr
+writeMaybe wr ptr (Just x) = wr (castPtr ptr) x
+
+readMaybe :: (Ptr a -> IO b) -> Ptr a -> IO (Maybe b)
+readMaybe rd ptr
+ | ptr == nullPtr = return Nothing
+ | otherwise      = rd ptr >>= return . Just
+
+writeunique :: IO (Ptr a)
+	    -> (Ptr a -> a -> IO ())
+	    -> Ptr (Maybe a)
+	    -> Maybe a
+	    -> IO ()
+writeunique allocRef marshallInto p mb =
+  case mb of
+    Nothing  -> writePtr (castPtr p) nullPtr
+    Just x   -> writeref allocRef marshallInto (castPtr p) x
+
+-- used to handle unique function pointers, since their marshallers
+-- have a non-standard type (cf. 2nd arg.)
+writeunique_fun :: IO (Ptr a)
+	        -> (Ptr (Ptr a) -> a -> IO ())
+ 	        -> Ptr (Maybe a)
+	        -> Maybe a
+	        -> IO ()
+writeunique_fun allocRef marshallInto p mb =
+  case mb of
+    Nothing  -> writePtr (castPtr p) nullPtr
+    Just x   -> writeref allocRef (\ pv v -> marshallInto (castPtr pv) v) (castPtr p) x
+
+unmarshallunique :: (Ptr a -> IO a) -> Ptr a -> IO (Maybe a)
+unmarshallunique refUnmarshall ptr
+ | ptr == nullPtr = return Nothing
+ | otherwise      = do
+    x <- unmarshallref refUnmarshall ptr
+    return (Just x)
+
+
+readunique :: (Ptr a -> IO a) -> Ptr b -> IO (Maybe a)
+readunique refUnmarshall ptr
+ | ptr == nullPtr = return Nothing
+ | otherwise      = do
+   v <- readPtr (castPtr ptr)
+   if nullPtr == v then
+      return Nothing
+    else do
+      x <- refUnmarshall (castPtr v)
+      return (Just x)
+
+freeunique :: (Ptr a -> IO ()) -> Ptr (Ptr a) -> IO ()
+freeunique freeptee ptr
+ | ptr == nullPtr = return ()
+ | otherwise      = do
+    ptr' <- derefPtr ptr
+    freeptee ptr'
+    free ptr
+
+
+--Marshalling [unique]void* pointers
+
+marshallunique_ptr :: Maybe (Ptr a) -> IO (Ptr a)
+marshallunique_ptr mb = 
+  case mb of
+    Nothing -> marshallPtr nullPtr
+    Just x  -> marshallPtr x
+
+
+--[ref]Ptr marshalling
+
+marshallref :: (IO (Ptr a)) -> (Ptr a -> a -> IO ()) -> a -> IO (Ptr a)
+marshallref allocRef marshallInto v = do
+   px <- allocRef
+   marshallInto px v
+   return px
+
+writeref :: (IO (Ptr a)) -> (Ptr a -> a -> IO ()) -> Ptr (Ptr a) -> a -> IO ()
+writeref allocRef marshallInto ptr v = do
+  px <- marshallref allocRef marshallInto v
+  writePtr ptr px
+
+unmarshallref :: (Ptr a -> IO b) -> Ptr a -> IO b
+unmarshallref refUnmarshall ptr = refUnmarshall ptr
+
+readref :: (Ptr a -> IO a) -> Ptr (Ptr a) -> IO a
+readref refUnmarshall ptr = do
+  px <- readPtr ptr
+  unmarshallref refUnmarshall (castPtr px)
+
+freeref :: (Ptr b -> IO ()) -> Ptr a -> IO ()
+freeref free_inner pptr = do
+   ptr <- readPtr (castPtr pptr)
+   free_inner ptr
+   free pptr
+
+--All by-reference marshalling and unmarshalling functions
+--of enums can be expressed using these two stubs:
+
+writeenum16 :: (b -> IO Int16) -> Ptr Int16 -> b -> IO ()
+writeenum16 marshall pv v =
+  marshall v >>= \ x ->
+  writeInt16 pv x
+
+readenum16 :: (Int16 -> IO a) -> Ptr (Int16) -> IO a
+readenum16 unmarshall pv = do
+  v <- readInt16 pv
+  unmarshall v
+
+marshallEnum16 :: Enum a => a -> IO Int16
+marshallEnum16 v = return (fromIntegral (fromEnum v))
+
+unmarshallEnum16 :: Enum a => Int16 -> IO a
+unmarshallEnum16 x = return (toEnum (fromIntegral x))
+
+marshallEnum32 :: Enum a => a -> IO Int32
+marshallEnum32 v = return (fromIntegral (fromEnum v))
+
+unmarshallEnum32 :: Enum a => Int32 -> IO a
+unmarshallEnum32 x = return (toEnum (fromIntegral x))
+
+writeEnum32 :: Enum a => Ptr b -> a -> IO ()
+writeEnum32 p v = writeInt32 (castPtr p) (fromIntegral (fromEnum v))
+
+readEnum32 :: Enum a => Ptr b -> IO a
+readEnum32 p = do
+  x <- readInt32 (castPtr p)
+  return (toEnum (fromIntegral x))
+
+writeEnum16 :: Enum a => Ptr b -> a -> IO ()
+writeEnum16 p v = writeInt16 (castPtr p) (fromIntegral (fromEnum v))
+
+readEnum16 :: Enum a => Ptr b -> IO a
+readEnum16 p = do
+  x <- readInt16 (castPtr p)
+  return (toEnum (fromIntegral x))
+
+marshalllist :: Word32
+	     -> (Ptr a -> a -> IO ())
+	     -> [a]
+	     -> IO (Ptr b)
+marshalllist szof writeelt ls = do
+ arr <- alloc (len*szof)
+ foldM writeElt (castPtr arr) ls
+ return (castPtr arr)
+  where
+   len = fromIntegral (length ls)
+
+   writeElt addr v = do
+     writeelt addr v
+     return (addNCastPtr addr szof)
+
+unmarshalllist :: Word32 -> Word32 -> Word32 -> (Ptr any -> IO a) -> Ptr b -> IO [a]
+unmarshalllist szof offset len unpack ptr = do
+ let ptr0 = addNCastPtr ptr (offset*szof)
+ loop ptr0 len
+  where
+   loop _ 0 = return []
+   loop p n = do
+    v  <- unpack p
+    let p' = addNCastPtr p szof
+    vs <- loop p' (n-1)
+    return (v:vs)
+
+unmarshallSingle :: (Ptr a -> IO a) -> Ptr a -> IO [a]
+unmarshallSingle ref ptr 
+ | ptr == nullPtr = return []
+ | otherwise      = do
+      x <- ref ptr
+      return [x]
+
+writelist :: Bool -> Word32 -> (Ptr a -> a -> IO ()) -> Ptr [a] -> [a] -> IO ()
+writelist do_alloc szof writeelt pptr ls = do
+ the_ptr <- 
+    (if do_alloc then do
+        ptr <- alloc (szof * fromIntegral len)
+	writePtr (castPtr pptr) ptr
+	return (castPtr ptr)
+      else
+        return (castPtr pptr))
+ foldM writeElt the_ptr ls
+ return ()
+  where
+   len = length ls
+
+   writeElt addr v = do
+    writeelt addr v
+    return (addNCastPtr addr szof)
+
+readlist :: Word32 -> Word32 -> (Ptr a -> IO a) -> Ptr [a] -> IO [a]
+readlist szof len unpack ptr = do
+ let ptr0 = castPtr ptr
+ loop ptr0 len
+  where
+   loop _ 0 = return []
+   loop p n = do
+    v  <- unpack p
+    let p' = addNCastPtr p szof
+    vs <- loop p' (n-1)
+    return (v:vs)
+
+freelist :: Word32 -> Word32 -> (Ptr a -> IO ()) -> Ptr [a] -> IO ()
+freelist szof len free_elt ptr = do
+	go (castPtr ptr) len
+	free ptr
+  where
+    go _pptr 0 = return ()
+    go pptr  x = do
+       p <- readPtr pptr
+       free_elt p
+       let pptr' = addNCastPtr pptr szof
+       go pptr' (x-1)
+
+--Unpacking null terminated character strings:
+
+marshallString :: String -> IO (Ptr String)
+marshallString str = do
+ pstr  <- alloc (len*sizeofChar)
+ pstr' <- foldM writeElt (castPtr pstr) str
+ writeChar (castPtr pstr') '\0'
+ return pstr
+  where
+   len = fromIntegral (length str + 1)
+
+   writeElt addr v = do
+     writeChar addr v
+     return (addNCastPtr addr sizeofChar)
+
+marshallBString :: Int -> String -> IO (Ptr String)
+marshallBString len str = do
+ pstr  <- alloc (len'*sizeofChar)
+ pstr' <- foldM writeElt (castPtr pstr) (take len str)
+ writeChar (castPtr pstr') '\0'
+ return pstr
+  where
+   len' = fromIntegral (len + 1)
+
+   writeElt addr v = do
+     writeChar addr v
+     return (addNCastPtr addr sizeofChar)
+
+unmarshallString :: Ptr String -> IO String
+unmarshallString ptr
+ | ptr == nullPtr  = return ""
+ | otherwise	   = do
+   let ptr0 = addNCastPtr ptr 0
+   loop ptr0
+  where
+   loop p = do
+    v  <- readChar p
+    if v == '\0'
+     then return []
+     else do
+       let p' = addNCastPtr p sizeofChar
+       vs <- loop p'
+       return (v:vs)
+
+-- at most len chars. or zero terminated.
+unmarshallBString :: Int -> Ptr String -> IO String
+unmarshallBString len ptr
+ | ptr == nullPtr  = return ""
+ | otherwise	   = do
+   let ptr0 = addNCastPtr ptr 0
+   loop ptr0 0
+  where
+   loop _ n | n > len = return ""
+   loop p n = do
+    v  <- readChar p
+    if v == '\0'
+     then return []
+     else do
+       let p' = addNCastPtr p sizeofChar
+       vs <- loop p' (n+1)
+       return (v:vs)
+
+readString :: Ptr (Ptr String) -> IO String
+readString pstr = do
+  ptr <- readPtr pstr
+  unmarshallString ptr
+
+readBString :: Int -> Ptr (Ptr String) -> IO String
+readBString len pstr = do
+  ptr <- readPtr pstr
+  unmarshallBString len ptr
+
+writeString :: Bool -> Ptr String -> String -> IO ()
+writeString do_alloc ppstr str = do
+  pstr <-
+    if not do_alloc then
+       return (castPtr ppstr)
+     else do
+       arr <- alloc (fromIntegral string_len)
+       writePtr (castPtr ppstr) arr
+       return arr
+  pstr' <- foldM writeElt (castPtr pstr) str
+  writeChar (castPtr pstr') '\0'
+ where
+   string_len = length str + 1 {- terminator -}
+
+   writeElt addr v = do
+     writeChar addr v
+     return (addNCastPtr addr sizeofChar)
+
+writeBString :: Bool -> Int -> Ptr a -> String -> IO ()
+writeBString do_alloc len ptr str = do
+  pstr  <-
+    if do_alloc then
+        alloc (fromIntegral len * sizeofChar)
+    else
+        return (castPtr ptr)
+  pstr' <- foldM writeElt pstr (take len str)
+  writeChar pstr' '\0'
+ where
+   writeElt addr v = do
+     writeChar addr v
+     return (addNCastPtr addr sizeofChar)
+
+freeString :: Ptr String -> IO ()
+freeString = free
+
+--Sequence marshallers - i.e., R/W a sequence of values to/from a list.
+
+marshallSequence :: (Ptr a -> a -> IO ())
+		 -> (Ptr a -> IO ())
+		 -> Word32
+		 -> Maybe Word32
+		 -> [a]
+		 -> IO (Ptr a)
+marshallSequence wElt wTermin szElt mbLen ls = do
+   pseq  <- alloc (len*szElt) -- assume that the sequence is packed without gaps.
+   pseq' <- foldM writeElt pseq the_ls
+   wTermin pseq'
+   return pseq'
+  where
+    (len, the_ls) = 
+      case mbLen of
+        Nothing -> (fromIntegral (length ls + 1), ls)
+	Just x  -> (x + 1, take (fromIntegral x) ls)
+
+    writeElt addr v = do
+      wElt addr v
+      return (addNCastPtr addr szElt)
+
+unmarshallSequence :: ( Eq a )
+		   => (Ptr (Ptr a) -> IO a)
+		   -> (Ptr (Ptr a) -> IO Bool)
+		   -> Word32
+		   -> Maybe Word32
+		   -> Ptr (Ptr a)
+		   -> IO [a]
+unmarshallSequence rElt termPred szElt mbLen ptr
+ | ptr == nullPtr  = return []
+ | otherwise	   = do
+   let ptr0 = addNCastPtr ptr 0
+   loop 0 ptr0
+  where
+   lenPred = 
+     case mbLen of
+       Nothing -> const False
+       Just x  -> \ y -> y >= x
+
+   loop len p = do
+    flg <- termPred p
+    if flg || (lenPred len)
+     then return []
+     else do
+       v  <- rElt p
+       let p' = addNCastPtr p szElt
+       vs <- loop (len+1) p'
+       return (v:vs)
+
+readSequence :: ( Eq a )
+	     => (Ptr (Ptr a) -> IO a)
+	     -> (Ptr (Ptr a) -> IO Bool)
+	     -> Word32
+	     -> Maybe Word32
+	     -> Ptr (Ptr a)
+	     -> IO [a]
+readSequence rElt termPred szElt mbLen ptr = do
+  ptr' <- readPtr ptr
+  unmarshallSequence rElt termPred szElt mbLen (castPtr ptr')
+
+writeSequence :: ( Eq a )
+	      => Bool
+	      -> (Ptr a -> a -> IO ())
+	      -> (Ptr a -> IO ())
+	      -> Word32
+	      -> Maybe Word32
+	      -> Ptr a 
+	      -> [a] 
+	      -> IO ()
+writeSequence do_alloc wElt wTermin szElt mbLen ppseq ls = do
+  pseq <-
+    if not do_alloc then
+       return (castPtr ppseq)
+     else do
+       arr <- alloc (szElt * seq_len)
+       writePtr (castPtr ppseq) arr
+       return arr
+  pseq' <- foldM writeElt pseq the_ls
+  wTermin pseq'
+ where
+   (seq_len, the_ls) = 
+      case mbLen of
+        Nothing -> (fromIntegral (length ls + 1), ls)
+	Just x  -> (x + 1, take (fromIntegral x) ls)
+
+   writeElt addr v = do
+     wElt addr v
+     return (addNCastPtr addr szElt)
+
+freeSequence :: Ptr a -> IO ()
+freeSequence = free
+
+-- at most len elements
+marshallblist :: Word32 -> Word32 -> (Ptr a -> a -> IO ()) -> [a] -> IO (Ptr [a])
+marshallblist szof l writeelt ls = do
+ arr <- alloc (l'*szof)
+ foldM writeElt (castPtr arr) ls
+ return arr
+  where
+   l' = atLeast l (fromIntegral (0::Int)) ls
+
+   atLeast len  n _ | len == n = len
+   atLeast _len n [] = n
+   atLeast len  n (_:xs) = atLeast len (n+1) xs
+
+   writeElt addr v = do
+    writeelt addr v
+    return (addNCastPtr addr szof)
+
+writeblist :: Word32 -> Word32 -> (Ptr a -> a -> IO ()) -> Ptr [a] -> [a] -> IO ()
+writeblist szof len writeelt ptr ls = do
+ foldM writeElt (castPtr ptr) (take (fromIntegral len) ls)
+ return ()
+  where
+
+   writeElt addr v = do
+    writeelt addr v
+    return (addNCastPtr addr szof)
+
+readblist :: Word32 -> Word32 -> (Ptr a -> IO a) -> Ptr a -> IO [a]
+readblist szof len unpack ptr = do
+ let ptr0 = castPtr ptr
+ loop ptr0 len
+  where
+   loop _p 0 = return []
+   loop p n  = do
+    v  <- unpack p
+    let p' = addNCastPtr p szof
+    vs <- loop p' (n-1)
+    return (v:vs)
+
+
+--Misc coercion functions/shortcuts:
+--(ToDo: try to avoid generating them in the first place!)
+
+word16ToInt32 :: Word16 -> Int32
+word16ToInt32 w = fromIntegral w -- intToInt32 (word16ToInt w)
+
+-- This coercion is relying on no exceptions being thrown if
+-- the Word32 > (maxBound::Int32).
+word32ToInt32 :: Word32 -> Int32
+word32ToInt32 w = fromIntegral w
+
+-- This coercion is reling on no exceptions being thrown if w < 0.
+int32ToWord32 :: Int32 -> Word32
+int32ToWord32 w = fromIntegral w
+
+int16ToWord32 :: Int16 -> Word32
+int16ToWord32 w = fromIntegral w -- intToWord32 (int16ToInt w)
+
+intToChar :: Int -> Char
+intToChar = chr
+
+charToInt32 :: Char -> Int32
+charToInt32 c = fromIntegral (ord c)
+
+word32ToChar :: Word32 -> Char
+word32ToChar w = chr (fromIntegral w)
+
+charToWord32 :: Char -> Word32
+charToWord32 c = fromIntegral (ord c)
+
+
+toInt32 :: Integral a => a -> Int32
+toInt32 i = fromIntegral i -- intToInt32 (toInt i)
+
+toInt16 :: Integral a => a -> Int16
+toInt16 i = fromIntegral i -- intToInt16 (toInt i)
+
+--ForeignPtr marshallers:
+
+marshallFO :: ForeignPtr a -> IO (ForeignPtr a)
+marshallFO x = return x
+
+unmarshallFO :: ForeignPtr a -> IO (ForeignPtr a)
+unmarshallFO x = return x
+
+writeFO :: Ptr (ForeignPtr a) -> ForeignPtr a -> IO ()
+writeFO ptr fo = poke (castPtr ptr) (foreignPtrToPtr fo)
+
+-- a C pointer, really.
+sizeofForeignPtr :: Word32
+sizeofForeignPtr = sizeofPtr
+
+nullFinaliser :: FunPtr (Ptr a -> IO ())
+nullFinaliser = castFunPtr (castPtrToFunPtr finalNoFree)
+
+nullFO :: ForeignPtr a
+nullFO = unsafePerformIO $ makeFO nullPtr nullFinaliser
+
+readStablePtr :: Ptr (StablePtr a) -> IO (StablePtr a)
+readStablePtr ptr = peek ptr
+
+--Default by-value 'marshallers' for structs and unions.
+
+marshallStruct :: String -> a -> IO b
+marshallStruct nm _ = ioError (userError (nm ++ ": Marshalling structs by value is not supported yet."))
+
+unmarshallStruct :: String -> a -> IO c
+unmarshallStruct nm _ = ioError (userError (nm ++ ": Unmarshalling structs by value is not supported yet."))
+
+marshallUnion :: String -> a -> IO b
+marshallUnion nm _ = ioError (userError (nm ++ ": Marshalling unions by value is not supported yet."))
+
+unmarshallUnion :: String -> a -> b -> IO c
+unmarshallUnion nm _ _ = ioError (userError (nm ++ ": Unmarshalling unions by value is not supported yet."))
+
+--Ptr marshallers:
+
+marshallPointer :: Ptr a -> IO (Ptr a)
+marshallPointer p = return p
+
+unmarshallPointer :: Ptr a -> IO (Ptr a)
+unmarshallPointer ptr = return ptr --makeNoFreePtr ptr
+
+writePointer :: Ptr (Ptr a) -> Ptr a -> IO ()
+writePointer = poke
+
+readPointer :: Ptr (Ptr a) -> IO (Ptr a)
+readPointer ptr = peek ptr
+
+sizeofPtr :: Word32
+sizeofPtr  = fromIntegral (sizeOf (undefined :: Foreign.Ptr.Ptr ()))
+
+primInvokeIt :: (Ptr b -> Ptr a -> IO c) -> Int -> IO (Ptr a) -> IO c
+primInvokeIt meth offset mk_obj_ptr = do
+  obj_ptr <- mk_obj_ptr 
+  lpVtbl  <- derefPtr (castPtr obj_ptr)
+  methPtr <- indexPtr lpVtbl offset
+  meth methPtr obj_ptr
+
+primInvokeItFO :: (Ptr b -> Ptr a -> IO c) -> Int -> IO (ForeignPtr a) -> IO c
+primInvokeItFO meth offset mk_obj_ptr = do
+  obj_ptr <- mk_obj_ptr
+  lpVtbl  <- peek (foreignPtrToPtr (castForeignPtr obj_ptr))
+  methPtr <- indexPtr lpVtbl offset
+  withForeignPtr obj_ptr (\ optr -> meth methPtr optr)
+
+stackStringLen :: Int -> String -> (Ptr String -> IO a) -> IO a
+stackStringLen len str f
+      = let slen = length str + 1 `max` len
+        in stackFrame (fromIntegral slen) $ \pstr -> do 
+	 writeString False pstr str
+         f pstr
+
+{- BEGIN_GHC_ONLY
+
+enumToFlag :: Enum a => a -> Int
+enumToFlag tg = fromIntegral ((1::Word32) `shiftL` enumToInt tg)
+
+enumToInt :: Enum a => a -> Int
+enumToInt tg = I# (getTag tg)
+
+flagToIntTag :: Int -> Int
+flagToIntTag f | f < 0     = error "flagToIntTag: negative tag"
+               | otherwise = go 0 f
+   -- could've used Prelude.logBase, but don't need the precision it offers.
+ where
+    go n 0 = n
+    go n 1 = n + 1
+    go n x = go (n + 1) (x `div` 2)
+
+unboxInt :: Int -> Int#
+unboxInt (I# x#) = x#
+
+toIntFlag :: Int -> Int -> Int
+toIntFlag b v = fromIntegral ((1::Word32) `shiftL` (v + flagToIntTag b))
+
+   END_GHC_ONLY -}
+
+pow2Series :: Int -> Int32 -> [Int32]
+pow2Series len start = take len (iterate double start)
+ where
+   double x
+     | x == 0    = 1
+     | otherwise = 2*x
+
+orList :: [Int] -> Int
+orList ls = fromIntegral (foldl (\ acc x -> (fromIntegral x) .|. acc) (0::Int32) ls)
+
+orFlags :: (Num a,Flags a) => [a] -> a
+orFlags ls = foldl (.+.) 0 ls
+
+class Flags a where
+  (.+.) :: a -> a -> a
+
+ System/Win32/Com/HDirect/Pointer.hs view
@@ -0,0 +1,126 @@+{-# OPTIONS -#include "PointerSrc.h" #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  System.Win32.Com.HDirect.Pointer+-- Copyright   :  (c) Daan Leijen, leijen@@fwi.uva.nl 1998+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  sof@galois.com+-- Stability   :  provisional+-- Portability :  portable+--+-- This module is part of HaskellDirect (H\/Direct), providing +-- helper functions over Ptrs + allocation\/freeing of memory via+-- malloc\/free or the COM task allocator.+--+-----------------------------------------------------------------------------+module System.Win32.Com.HDirect.Pointer  +	( +	  Ptr+	+	, allocMemory+	, stackFrame++	, writeSeqAtDec++        , freeMemory+	, freeBSTR+	, freeWith+	, freeWithC+	+	, primNoFree+	+	, finalNoFree+	, finalFreeMemory+	+	, makeFO++       ) where++import Foreign.Ptr+import Foreign.ForeignPtr+import System.Win32.Com.HDirect.PointerPrim+import Data.Word     ( Word32 )+import Control.Monad+++type Finalizer a  = Ptr a -> IO ()++makeFO :: Ptr a -> FunPtr (Ptr a -> IO ()) -> IO (ForeignPtr b)+{- BEGIN_GHC_ONLY +#if __GLASGOW_HASKELL__ > 601+makeFO obj finaliser = newForeignPtr (mkFinal finaliser obj) obj >>= return.castForeignPtr+#else+makeFO obj finaliser = newForeignPtr obj (mkFinal finaliser obj) >>= return.castForeignPtr+#endif+   END_GHC_ONLY -}+{- BEGIN_NOT_FOR_GHC -}+-- Versionitis. If your version of Hugs is troubled by this one, simply enable the other version.+makeFO obj finaliser = newForeignPtr (mkFinal finaliser obj) obj >>= return.castForeignPtr+--makeFO obj finaliser = newForeignPtr obj (mkFinal finaliser obj) >>= return.castForeignPtr+{- END_NOT_FOR_GHC -}++{- BEGIN_GHC_ONLY+#if __GLASGOW_HASKELL__ < 505+mkFinal final obj = ap0 final obj+foreign import ccall "dynamic" ap0 :: FunPtr (Ptr a -> IO()) -> (Ptr a -> IO ())+#else+mkFinal final _ = final+#endif+   END_GHC_ONLY -}+{- BEGIN_NOT_FOR_GHC -}+mkFinal final _ = final+{- END_NOT_FOR_GHC -}++--Helpers.++writeSeqAtDec :: Word32 -> [Ptr a -> IO ()] -> Ptr a -> IO ()+writeSeqAtDec size ws ptr = go init_ptr ws+  where+   len           = fromIntegral (length ws - 1)+   init_ptr      = ptr `plusPtr` (size_i * len)+   size_i        = fromIntegral size++   go _   []     = return ()+   go ptr (x:xs) = do+      x ptr+      let ptr_next = ptr `plusPtr` (-size_i)+      go ptr_next xs+++-- | Use 'stackFrame' when the allocated chunk have a +-- limited and known lifetime.+stackFrame :: Word32 -> (Ptr a -> IO b) -> IO b+stackFrame size f+      = do p <- allocMemory size+           f p `always` primFreeMemory (castPtr p)+++-- Special free routines for pointers. Use them to manually free pointers.++freeMemory            = freeWithC primFreeMemory+freeBSTR              = freeWithC primFreeBSTR++freeWithC :: Finalizer () -> Ptr a -> IO ()+freeWithC final p = final (castPtr p)++freeWith :: (Ptr a -> IO ()) -> Ptr a -> IO ()+freeWith free p = free p ++-- Helper functions that doesn't really have a good home to go to:++always :: IO a -> IO () -> IO a+always io action+      = do x <- io `catch` (\ err -> do { action; ioError err })+           action+           return x++--Primitives/helpers:++allocMemory :: Word32 -> IO (Ptr a)+allocMemory sz = do+  a <- primAllocMemory sz+  if a == nullPtr then+     ioError (userError "allocMemory: not enough memory")+   else+     return (castPtr a)
+ System/Win32/Com/HDirect/PointerPrim.hs view
@@ -0,0 +1,63 @@+{-# OPTIONS -#include "PointerSrc.h" #-}
+-- Automatically generated by HaskellDirect (ihc.exe), snapshot 171208
+-- Created: 23:37 Pacific Standard Time, Wednesday 17 December, 2008
+-- Command line: -fno-qualified-names -fkeep-hresult -fout-pointers-are-not-refs -c System/Win32/Com/HDirect/PointerPrim.idl -o System/Win32/Com/HDirect/PointerPrim.hs
+
+module System.Win32.Com.HDirect.PointerPrim
+       ( primNoFree
+       , primFreeBSTR
+       , primFreeMemory
+       , finalNoFree
+       , finalFreeMemory
+       , primAllocMemory
+       , primFinalise
+       ) where
+       
+import Prelude
+import Data.Word (Word32)
+import Foreign.Ptr (Ptr)
+import System.IO.Unsafe (unsafePerformIO)
+
+primNoFree :: Ptr ()
+           -> IO ()
+primNoFree p =
+  prim_System_Win32_Com_HDirect_PointerPrim_primNoFree p
+
+foreign import ccall "primNoFree" prim_System_Win32_Com_HDirect_PointerPrim_primNoFree :: Ptr () -> IO ()
+primFreeBSTR :: Ptr ()
+             -> IO ()
+primFreeBSTR p =
+  prim_System_Win32_Com_HDirect_PointerPrim_primFreeBSTR p
+
+foreign import ccall "primFreeBSTR" prim_System_Win32_Com_HDirect_PointerPrim_primFreeBSTR :: Ptr () -> IO ()
+primFreeMemory :: Ptr ()
+               -> IO ()
+primFreeMemory p =
+  prim_System_Win32_Com_HDirect_PointerPrim_primFreeMemory p
+
+foreign import ccall "primFreeMemory" prim_System_Win32_Com_HDirect_PointerPrim_primFreeMemory :: Ptr () -> IO ()
+finalNoFree :: Ptr ()
+finalNoFree =
+  unsafePerformIO (prim_System_Win32_Com_HDirect_PointerPrim_finalNoFree)
+
+foreign import ccall "finalNoFree" prim_System_Win32_Com_HDirect_PointerPrim_finalNoFree :: IO (Ptr ())
+finalFreeMemory :: Ptr ()
+finalFreeMemory =
+  unsafePerformIO (prim_System_Win32_Com_HDirect_PointerPrim_finalFreeMemory)
+
+foreign import ccall "finalFreeMemory" prim_System_Win32_Com_HDirect_PointerPrim_finalFreeMemory :: IO (Ptr ())
+primAllocMemory :: Word32
+                -> IO (Ptr ())
+primAllocMemory sz =
+  prim_System_Win32_Com_HDirect_PointerPrim_primAllocMemory sz
+
+foreign import ccall "primAllocMemory" prim_System_Win32_Com_HDirect_PointerPrim_primAllocMemory :: Word32 -> IO (Ptr ())
+primFinalise :: Ptr ()
+             -> Ptr ()
+             -> IO ()
+primFinalise finaliser finalisee =
+  prim_System_Win32_Com_HDirect_PointerPrim_primFinalise finaliser
+                                                         finalisee
+
+foreign import ccall "primFinalise" prim_System_Win32_Com_HDirect_PointerPrim_primFinalise :: Ptr () -> Ptr () -> IO ()
+
+ System/Win32/Com/HDirect/WideString.hs view
@@ -0,0 +1,152 @@+{-# OPTIONS -#include <stdlib.h> #-}
+{-# OPTIONS -#include "WideStringSrc.h" #-}
+{-# OPTIONS -#include "PointerSrc.h" #-}
+-- Automatically generated by HaskellDirect (ihc.exe), snapshot 171208
+-- Created: 23:37 Pacific Standard Time, Wednesday 17 December, 2008
+-- Command line: -fno-qualified-names -fno-imports -fno-export-lists -fkeep-hresult -fout-pointers-are-not-refs -c System/Win32/Com/HDirect/WideString.idl -o System/Win32/Com/HDirect/WideString.hs
+
+module System.Win32.Com.HDirect.WideString where
+
+
+
+import System.Win32.Com.HDirect.PointerPrim      ( primAllocMemory )
+import System.Win32.Com.HDirect.Pointer          ( stackFrame, freeMemory )
+import Foreign.Ptr      ( castPtr, nullPtr, plusPtr )
+import System.Win32.Com.HDirect.HDirect
+import System.IO.Unsafe ( unsafePerformIO )
+
+type LPWSTR = WideString
+type LPCWSTR = WideString
+
+newtype WideString = WideString (Ptr Wchar_t)
+
+lengthWideString :: WideString -> Int
+lengthWideString (WideString ws) = unsafePerformIO (lenWideString ws >>= return . fromIntegral)
+
+stackWideString :: String -> (Ptr Wchar_t -> IO a) -> IO a
+stackWideString str wcont = do
+    stackString str $ \ len pstr -> do
+    let wlen = wideStringLen pstr
+    stackFrame (sizeofWideString*(wlen+1)) $ \ pwide -> do
+    primStringToWide pstr (fromIntegral len) pwide wlen 
+    wcont pwide
+
+mkWideString :: String -> WideString
+mkWideString ls = unsafePerformIO (stringToWide ls)
+
+stringToWide :: String -> IO WideString
+stringToWide str =
+  stackString str $ \ len pstr -> do
+  let wlen = wideStringLen pstr
+   -- Note: we're using the task allocator here.
+  pwide <- primAllocMemory ((wlen + 1) * sizeofWideString)
+  primStringToWide pstr (fromIntegral len) (castPtr pwide) wlen
+  unmarshallWideString (castPtr pwide)
+
+-- Sometimes a (wchar_t*) double up as holding a 16-bit (yep, no kidding) -
+-- higher 16 bits have to be zero, lower 16 the val. We *love* this stuff.
+word16ToWideString :: Word16 -> IO WideString
+word16ToWideString w = 
+  return (WideString (plusPtr nullPtr (fromIntegral w)))
+
+nullWideString :: WideString
+nullWideString = WideString (nullPtr)
+
+-- Does not belong here - at all.
+
+stackString :: String -> (Int -> Ptr Char -> IO a) -> IO a
+stackString str pcont = do
+   let len = 1 + fromIntegral (length str)
+   stackFrame len $ \ ptr -> do
+   writeString False ptr str
+   pcont (fromIntegral len) (castPtr ptr)
+
+marshallWideString :: WideString -> IO (Ptr WideString)
+marshallWideString (WideString ptr) = marshallPointer ptr >>= return.castPtr
+
+marshallWideString2 :: String -> IO (Ptr WideString)
+marshallWideString2 str = do
+  wstr <- stringToWide str
+  marshallWideString wstr
+
+-- using 'Ptr a' is too weak, really - but avoids trivial
+-- problems wrt WideString/Wchar_t confusion. ToDo: tidy up.
+unmarshallWideString :: Ptr a -> IO WideString
+unmarshallWideString ptr = do
+  po <- unmarshallPointer ptr
+  return (WideString (castPtr po))
+
+unmarshallWideString2 :: Ptr a -> IO String
+unmarshallWideString2 ptr = do
+  po <- unmarshallPointer ptr
+  wideToStr (WideString (castPtr po))
+
+-- writeWideString doesn't copy the wide string, it merely
+-- fills in a pointer to the wide string.
+
+writeWideString :: Ptr WideString -> WideString -> IO ()
+writeWideString ptr (WideString pstr) = writePointer (castPtr ptr) pstr
+
+writeWideString2 :: Ptr WideString -> String -> IO ()
+writeWideString2 ptr str = do
+   pwstr <- marshallWideString2 str
+   writePointer (castPtr ptr) pwstr
+
+-- is this correct?
+readWideString :: Ptr WideString -> IO WideString
+readWideString p = unmarshallWideString (castPtr p)
+
+readWideString2 :: Ptr WideString -> IO String
+readWideString2 p = unmarshallWideString2 (castPtr p)
+
+freeWideString :: Ptr WideString -> IO ()
+freeWideString _ = return () --(WideString pstr) = freeMemory pstr
+
+freeWString :: WideString -> IO ()
+freeWString (WideString pstr) = freeMemory pstr
+
+sizeofWideString :: Word32
+sizeofWideString = 2  -- not set in stone.
+
+wideToStr :: WideString -> IO String
+wideToStr wide = do
+   pwide    <- marshallWideString wide
+   (pstr,_) <- wideToString (castPtr pwide)
+   unmarshallString (castPtr pstr)
+
+
+wideStringLen :: Ptr Char
+              -> Word32
+wideStringLen str =
+  unsafePerformIO (prim_System_Win32_Com_HDirect_WideString_wideStringLen str)
+
+foreign import ccall "wideStringLen" prim_System_Win32_Com_HDirect_WideString_wideStringLen :: Ptr Char -> IO Word32
+wideToString :: Ptr Wchar_t
+             -> IO (Ptr Char, Int32)
+wideToString wstr =
+  do
+    pstr <- allocBytes (fromIntegral sizeofPtr)
+    o_wideToString <- prim_System_Win32_Com_HDirect_WideString_wideToString wstr pstr
+    pstr <- doThenFree free readPtr pstr
+    return (pstr, o_wideToString)
+
+foreign import ccall "wideToString" prim_System_Win32_Com_HDirect_WideString_wideToString :: Ptr Word16 -> Ptr (Ptr Char) -> IO Int32
+lenWideString :: Ptr Wchar_t
+              -> IO Int32
+lenWideString wstr =
+  prim_System_Win32_Com_HDirect_WideString_lenWideString wstr
+
+foreign import ccall "lenWideString" prim_System_Win32_Com_HDirect_WideString_lenWideString :: Ptr Word16 -> IO Int32
+primStringToWide :: Ptr Char
+                 -> Word32
+                 -> Ptr Wchar_t
+                 -> Word32
+                 -> IO Int32
+primStringToWide str len wstr wlen =
+  prim_System_Win32_Com_HDirect_WideString_primStringToWide str
+                                                            len
+                                                            wstr
+                                                            wlen
+
+foreign import ccall "primStringToWide" prim_System_Win32_Com_HDirect_WideString_primStringToWide :: Ptr Char -> Word32 -> Ptr Word16 -> Word32 -> IO Int32
+
+ System/Win32/Com/Server.hs view
@@ -0,0 +1,721 @@+{-# 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)
+ System/Win32/Com/Server/ClassInfo.hs view
@@ -0,0 +1,104 @@+module System.Win32.Com.Server.ClassInfo
+         (
+	   mkIProvideClassInfo
+	 , mkIProvideClassInfo2
+
+	 , IProvideClassInfo(..)
+	 , IProvideClassInfo_
+	 , iidIProvideClassInfo
+
+	 , IProvideClassInfo2(..)
+	 , IProvideClassInfo2_
+	 , iidIProvideClassInfo2
+
+	 ) where
+
+import System.Win32.Com
+import Data.Word ( Word32 )
+import System.Win32.Com.Exception
+import System.Win32.Com.Automation.TypeLib
+import System.Win32.Com.Server
+import Foreign.Ptr
+import System.Win32.Com.HDirect.HDirect ( Ptr, writePtr )
+import System.Win32.Com.Base (lOCALE_USER_DEFAULT)
+import System.IO.Unsafe
+
+type ThisPtr = Ptr ()
+
+
+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]
+
+
+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)
+
+getClassInfo :: Maybe (ITypeLib ()) -> CLSID -> ThisPtr -> Ptr (Ptr (ITypeInfo ())) -> IO HRESULT
+getClassInfo mb_tlib clsid this ppTI 
+  | ppTI == nullPtr = return e_POINTER
+  | otherwise	    = do
+     case mb_tlib of
+       Nothing -> return e_FAIL
+       Just tl -> do
+	 catch (do
+           ti <- tl # getTypeInfoOfGuid (clsidToGUID clsid)
+	   writeIUnknown True ppTI ti
+	   return s_OK)
+	  (\ _ -> do
+	      writePtr ppTI nullPtr
+	      return e_FAIL)
+
+foreign import stdcall "wrapper" 
+   export_gci :: (Ptr () -> Ptr (Ptr (ITypeInfo ())) -> IO HRESULT) -> IO (Ptr ())
+
+getGUID :: IID a
+	-> ThisPtr
+	-> Word32
+	-> Ptr GUID
+	-> IO HRESULT
+getGUID iid this kind pGUID
+  | pGUID == nullPtr  = return e_POINTER
+  | kind  /= 1        = return e_INVALIDARG -- 1 == GUIDKIND_DEFAULT_SOUCE_DISP_IID
+  | otherwise         = do
+     writeGUID pGUID (iidToGUID iid)
+     return s_OK
+
+foreign import stdcall "wrapper"
+   export_gg :: (Ptr () -> Word32 -> Ptr (GUID) -> IO HRESULT) -> IO (Ptr ())
+ System/Win32/Com/Server/ConnectionPoint.hs view
@@ -0,0 +1,218 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Win32.Com.Server.ConnectionPoint
+-- 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
+--
+-- Generic implementation of COM connectable objects \/ connection points,
+-- server side.
+-- 
+-- The connection between this framework impl. and the Haskell object
+-- responsible for firing events on the registered sinks, is still
+-- up in the air. The current arrangement is for the object and a
+-- particular connection point to share an IORef holding the current
+-- set of registered sinks. The object will then fire the events
+-- by using the (generated) stubs for that particular event interface.
+-- 
+-- Probably want to abstract away the details of how sink broadcasting
+-- is done.
+-- 
+-----------------------------------------------------------------------------
+module System.Win32.Com.Server.ConnectionPoint 
+		(
+		  mkConnectionContainer
+		) where
+
+import System.Win32.Com.Server
+import System.Win32.Com.Automation.Connection ( iidIConnectionPointContainer, iidIConnectionPoint,
+		    IConnectionPointContainer, IConnectionPoint,
+		    iidIEnumConnections, iidIEnumConnectionPoints
+		  )
+		    
+import System.Win32.Com
+import System.Win32.Com.HDirect.HDirect ( writeWord32, Ptr, sizeofPtr )
+import System.Win32.Com.Server.EnumInterface ( mkEnumInterface )
+import Foreign.Ptr
+import Foreign.ForeignPtr
+import Foreign.Storable
+import System.IO.Unsafe ( unsafePerformIO )
+import System.IO        ( fixIO  )
+import Data.IORef       ( IORef, newIORef, readIORef, writeIORef )
+import Data.Word
+import Data.Int
+import System.Win32.Com.Exception
+
+type ThisPtr = Ptr (IUnknown ())
+
+mkConnectionContainer :: [(IID (IUnknown ()), IORef [(Word32, IUnknown ())])]
+                      -> IO (IConnectionPointContainer ())
+mkConnectionContainer ls = fixIO $ \ ip -> do
+  let ils = unsafePerformIO (mapM (mkConnection ip) ls)
+  addrOf_eCP <- export_enumCP (enumConnectionPoints (map snd ils))
+  addrOf_fCP <- export_fCP    (findConnectionPoint ils)
+  vtbl       <- createComVTable [ addrOf_eCP, addrOf_fCP ]
+  createComInstance "" () (return ())
+                    [mkIface iidIConnectionPointContainer vtbl]
+		    iidIConnectionPointContainer
+  
+mkConnection :: IConnectionPointContainer ()
+             -> (IID (IUnknown ()), IORef [(Word32, IUnknown ())])
+             -> IO (IID (IUnknown ()), IConnectionPoint ())
+mkConnection ip (iid, regd_sinks) = do
+  vtbl <- mkConnectionPointVTBL ip iid regd_sinks
+  ip   <- createComInstance "" () (return ())
+                            [ mkIface iidIConnectionPoint vtbl ]
+			    iidIConnectionPoint
+  return (iid, ip)
+
+mkConnectionPointVTBL :: IConnectionPointContainer ()
+		      -> IID (IUnknown iid)
+                      -> IORef [(Word32, IUnknown ())]
+                      -> IO (ComVTable (IConnectionPoint a) objState)
+mkConnectionPointVTBL ip iid sinks = do
+   addrOf_gi    <- export_gi    (getConnectionInterface iid)
+   addrOf_gcpc  <- export_gcpc  (getConnectionPointContainer ip)
+   cookie_ref   <- newIORef (0::Word32)
+   addrOf_adv   <- export_adv   (advise sinks cookie_ref iid)
+   addrOf_unadv <- export_unadv (unadvise sinks)
+   addrOf_eC    <- export_eCP   (enumConnections sinks)
+   createComVTable
+         [ addrOf_gi , addrOf_gcpc , addrOf_adv, addrOf_unadv, addrOf_eC ]
+
+getConnectionInterface :: IID iid
+                       -> ThisPtr
+		       -> Ptr GUID
+		       -> IO HRESULT
+getConnectionInterface iid _ piid 
+  | piid == nullPtr  = return e_POINTER
+  | otherwise        = do
+     writeGUID piid (iidToGUID iid)
+     return s_OK
+
+foreign import stdcall "wrapper"
+    export_gi :: (ThisPtr -> Ptr GUID -> IO HRESULT) -> IO (Ptr ())
+
+getConnectionPointContainer :: IConnectionPointContainer ()
+                            -> ThisPtr
+                            -> Ptr (Ptr (IUnknown b))
+                            -> IO HRESULT
+getConnectionPointContainer ip _ pip = do
+   writeIUnknown True{-addRef-} pip ip
+   return s_OK
+
+foreign import stdcall "wrapper"
+    export_gcpc :: (ThisPtr -> Ptr (Ptr (IUnknown b)) -> IO HRESULT) -> IO (Ptr ())
+
+advise :: IORef [(Word32,IUnknown ())]
+       -> IORef Word32
+       -> IID (IUnknown iid)
+       -> ThisPtr
+       -> PrimIP ()
+       -> Ptr Word32
+       -> IO HRESULT
+advise sinks cookie_ref iid this pUnkSink pdwCookie = do
+  ls      <- readIORef sinks
+  cookie  <- readIORef cookie_ref
+  ip      <- unmarshallIUnknown False pUnkSink
+  catch (do
+     ip2 <- ip # queryInterface iid
+     if nullPtr == pdwCookie then
+        return e_POINTER
+      else do
+        writeIORef cookie_ref (cookie+1)
+        writeIORef sinks ((cookie,castIface ip2):ls)
+        writeWord32 pdwCookie cookie
+        return s_OK
+   )(\ _ -> return cONNECT_E_CANNOTCONNECT)
+
+foreign import stdcall "wrapper"
+   export_adv :: (ThisPtr -> PrimIP () -> Ptr Word32 -> IO HRESULT) -> IO (Ptr ())
+
+unadvise :: IORef [(Word32,IUnknown ())]
+         -> ThisPtr
+         -> Word32
+         -> IO HRESULT
+unadvise sinks this dwCookie = do
+  ls     <- readIORef sinks
+  case break ((==dwCookie).fst) ls of
+    (ls,[])    -> return cONNECT_E_NOCONNECTION
+    (ls, _:rs) -> do
+	 -- just drop the interface pointer and let
+	 -- the GC release it.
+       writeIORef sinks (ls++rs)
+       return s_OK
+
+foreign import stdcall "wrapper"
+    export_unadv :: (ThisPtr -> Word32 -> IO HRESULT) -> IO (Ptr ())
+
+enumConnections :: IORef [(Word32,IUnknown ())]
+                -> ThisPtr
+	        -> Ptr (Ptr (IUnknown a))
+                -> IO HRESULT
+enumConnections sinks this ppCP
+  | ppCP == nullPtr  = return e_POINTER
+  | otherwise        = do
+    ls   <- readIORef sinks
+    vtbl <- mkEnumInterface (map snd ls) (fromIntegral sizeofPtr) (writeIUnknown True)
+    ip   <- createComInstance "" () (return ())
+	                      [mkIface iidIEnumConnections vtbl]
+			      iidIEnumConnections
+    writeIUnknown True ppCP ip
+    return s_OK
+
+foreign import stdcall "wrapper"
+    export_enumCP :: (ThisPtr -> Ptr (Ptr (IUnknown b)) -> IO HRESULT) -> IO (Ptr ())
+
+enumConnectionPoints :: [IConnectionPoint ()]
+                     -> ThisPtr
+                     -> Ptr (Ptr (IUnknown b))
+                     -> IO HRESULT
+enumConnectionPoints ls this ppEnum 
+  | ppEnum == nullPtr  = return e_POINTER
+  | otherwise	       = do
+     vtbl <- mkEnumInterface ls (fromIntegral sizeofPtr) (writeIUnknown True)
+     ip   <- createComInstance "" () (return ())
+	                           [mkIface iidIEnumConnectionPoints vtbl]
+				   iidIEnumConnectionPoints
+     writeIUnknown True ppEnum ip
+     return s_OK
+
+foreign import stdcall "wrapper"
+    export_eCP :: (ThisPtr -> Ptr (Ptr (IUnknown b)) -> IO HRESULT) -> IO (Ptr ())
+
+findConnectionPoint :: [(IID (IUnknown ()), IConnectionPoint ())]
+		    -> ThisPtr
+		    -> Ptr GUID
+		    -> Ptr (Ptr (IUnknown ()))
+		    -> IO HRESULT
+findConnectionPoint ls this riid ppCP 
+  | ppCP == nullPtr  = return e_POINTER
+  | otherwise        = do
+     guid <- unmarshallGUID False riid
+     let iid = guidToIID guid
+     case (lookup iid ls) of
+       Nothing -> do
+          poke ppCP nullPtr
+          return cONNECT_E_NOCONNECTION
+       Just i  -> do
+          writeIUnknown True ppCP i
+	  return s_OK
+
+foreign import stdcall "wrapper"
+    export_fCP :: (ThisPtr -> Ptr GUID -> Ptr (Ptr (IUnknown b)) -> IO HRESULT) -> IO (Ptr ())
+
+cONNECT_E_NOCONNECTION :: HRESULT
+cONNECT_E_NOCONNECTION = 0x80040200
+
+cONNECT_E_ADVISELIMIT :: HRESULT
+cONNECT_E_ADVISELIMIT  = 0x80040201
+
+cONNECT_E_CANNOTCONNECT :: HRESULT
+cONNECT_E_CANNOTCONNECT = 0x80040202
+
+cONNECT_E_OVERRIDDEN :: HRESULT
+cONNECT_E_OVERRIDDEN = 0x80040203
+ System/Win32/Com/Server/EnumInterface.hs view
@@ -0,0 +1,149 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Win32.Com.Server.EnumInterface
+-- 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
+--
+-- Generic implementation of Com-style enumeration
+-- interfaces - give it the list to enumerate & you're there!
+-- 
+-----------------------------------------------------------------------------
+module System.Win32.Com.Server.EnumInterface 
+	( 
+	  mkEnumInterface  -- :: [a]
+			   -- -> Int
+			   -- -> (Ptr a -> a -> IO ())
+			   -- -> IO (ComVTable iid objState)
+	) where
+
+import Data.Word
+import Data.Int
+import System.Win32.Com.Server
+import System.Win32.Com.Exception
+import System.Win32.Com ( HRESULT, writeIUnknown, IUnknown )
+import System.Win32.Com.HDirect.HDirect
+import Foreign.Ptr
+import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
+import Control.Monad ( when )
+
+type ThisPtr = Ptr (IUnknown ())
+
+--The state kept by each IEnum* instance:
+data EnumState a
+ = EnumState 
+     { elt      :: IORef ([a], Int)
+     , origElts :: [a]
+     , writeElt :: (Ptr (Ptr a) -> a -> IO ())
+     , sizeof   :: Int
+     }
+
+{-
+The constructor doesn't have to do much, initialise the state
+shared by the different methods and create a method table
+containing them:
+-}
+mkEnumInterface :: [a]
+	        -> Int
+		-> (Ptr (Ptr a) -> a -> IO ())
+		-> IO (ComVTable iid objState)
+mkEnumInterface ls sizeof write = do
+  ref <- newIORef (ls, length ls)
+  let st = EnumState ref ls write sizeof
+  m_enumNext  <- export_enumNext  (enumNext st)
+  m_enumSkip  <- export_enumSkip  (enumSkip st)
+  m_enumReset <- export_enumReset (enumReset st)
+  m_enumClone <- export_enumClone (enumClone st)
+  createComVTable [m_enumNext, m_enumSkip, m_enumReset, m_enumClone]
+
+{-
+An IEnum* interface allows you to iterate over a sequence *once*,
+i.e., it doesn't wrap around (but you can rewind the enumeration
+back to the beginning with IEnum::Reset()):
+-}
+enumNext :: EnumState a
+	 -> ThisPtr
+	 -> Word32
+	 -> Ptr (Ptr a)
+	 -> Ptr Word32
+	 -> IO HRESULT
+enumNext st this c pFetched pcFetched 
+  | pcFetched == nullPtr && c /= 1 = return e_INVALIDARG
+  | pFetched == nullPtr 	   = return e_POINTER
+  | otherwise			   = do
+     let ref = elt st
+     (elts, eltsLeft) <- readIORef ref
+     let
+      c_int = fromIntegral c
+      (hr, elts_to_fetch)
+       | c_int > eltsLeft  = (s_FALSE, eltsLeft)
+       | otherwise         = (s_OK,    c_int)
+       
+      elts_left = eltsLeft - elts_to_fetch
+
+     elts' <- fillIn pFetched elts_to_fetch  elts
+     when (pcFetched /= nullPtr)
+          (writeWord32 pcFetched (fromIntegral elts_to_fetch))
+     writeIORef ref (elts', elts_left)
+     return hr
+ where
+   wr_marshall = writeElt st
+
+   fillIn ptr 0 ls     = return ls
+   fillIn ptr n (x:xs) = do
+       wr_marshall ptr x
+       let ptr' = ptr `plusPtr` (fromIntegral (sizeof st))
+       fillIn ptr' (n-1) xs
+
+foreign import stdcall "wrapper"
+   export_enumNext :: (ThisPtr -> Word32 -> Ptr a -> Ptr Word32 -> IO HRESULT) -> IO (Ptr ())
+
+enumSkip :: EnumState a
+	 -> ThisPtr
+	 -> Word32
+	 -> IO HRESULT
+enumSkip st this c
+  | c == 0     = return e_INVALIDARG
+  | otherwise  = do
+     (elts, eltsLeft) <- readIORef (elt st)
+     let
+      c_int = fromIntegral c
+      (hr, elts_to_fetch)
+       | c_int > eltsLeft = (s_FALSE, eltsLeft)
+       | otherwise        = (s_OK,    c_int)
+
+      elts_left = take elts_to_fetch elts
+      x         = eltsLeft - elts_to_fetch
+
+     writeIORef (elt st) (elts_left, x)
+     return hr
+
+foreign import stdcall "wrapper"
+   export_enumSkip :: (ThisPtr -> Word32 -> IO HRESULT) -> IO (Ptr ())
+
+enumReset :: EnumState a
+	  -> ThisPtr
+	  -> IO HRESULT
+enumReset st _ = do
+  let ls = origElts st
+  writeIORef (elt st) (ls, length ls)
+  return s_OK
+
+foreign import stdcall "wrapper"
+   export_enumReset :: (ThisPtr -> IO HRESULT) -> IO (Ptr ())
+
+enumClone :: EnumState a
+	  -> ThisPtr
+	  -> Ptr (Ptr (IUnknown b))
+	  -> IO HRESULT
+enumClone st this out = do
+   vtbl <- mkEnumInterface (origElts st) (sizeof st) (writeElt st)
+   ip   <- cloneIPointer_prim this vtbl
+   writeIUnknown False out ip
+   return s_OK
+
+foreign import stdcall "wrapper"
+   export_enumClone :: (ThisPtr -> Ptr (Ptr (IUnknown b)) -> IO HRESULT) -> IO (Ptr ())
+ System/Win32/Com/Server/ExeServer.hs view
@@ -0,0 +1,97 @@+{-# OPTIONS -#include "comPrim.h" #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Win32.Com.Server.ExeServer
+-- 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
+--
+-- Generic implementation of separate process Com-server.
+-- 
+-----------------------------------------------------------------------------
+module System.Win32.Com.Server.ExeServer 
+	(
+	  runExeServer       -- :: ComponentInfo -> IO ()
+	, registerExeServer  -- :: String -> ComponentInfo -> IO ()
+	) where
+
+import System.Win32.Com.ClassFactory
+import System.Win32.Com.Dll
+import System.Win32.Com.Base
+import System.Win32.Com
+import System.Win32.Com.HDirect.HDirect
+import Data.Int
+import Foreign.StablePtr
+import Foreign.Ptr
+import Foreign.ForeignPtr
+import Data.Char ( toLower )
+
+runExeServer :: ComponentInfo -> IO ()
+runExeServer c = do
+  newStablePtr c
+  ev <- mkEvent
+  let c'=c{componentFinalise=componentFinalise c >> signalEvent ev}
+  ip <- createClassFactory (newInstance c' "" (componentFinalise c'))
+  pip    <- marshallIUnknown ip
+  pclsid <- marshallCLSID (componentCLSID c)
+  dw    <- coRegisterClassObject (castForeignPtr pclsid) pip
+  			(fromIntegral (fromEnum CLSCTX_LOCAL_SERVER))
+  			(fromIntegral (fromEnum REGCLS_SINGLEUSE))
+  waitForEvent ev
+  coRevokeClassObject dw
+  return ()
+  
+registerExeServer :: String -> ComponentInfo -> IO ()
+registerExeServer arg ci
+  | null arg  = return ()
+  | otherwise = do
+   let
+    arg_low  = map toLower (tail arg)
+    is_unreg = arg_low == "unregserver"
+    is_reg   = arg_low == "regserver"
+
+   if not is_unreg && not is_reg then
+      return ()
+    else do
+      path <- getModuleFileName nullPtr
+      (registerComponent ci) ci path is_reg
+      (if is_reg then stdRegComponent else stdUnRegComponent) ci False path
+
+data REGCLS 
+ = REGCLS_SINGLEUSE      --   = 0, 
+ | REGCLS_MULTIPLEUSE    --   = 1, 
+ | REGCLS_MULTI_SEPARATE --   = 2, 
+ | REGCLS_SUSPENDED      --   = 4, 
+ | REGCLS_SURROGATE      --   = 8, 
+
+instance Enum REGCLS where
+  fromEnum ctx =
+    case ctx of
+      REGCLS_SINGLEUSE      -> 0
+      REGCLS_MULTIPLEUSE    -> 1
+      REGCLS_MULTI_SEPARATE -> 2
+      REGCLS_SUSPENDED      -> 4
+      REGCLS_SURROGATE      -> 8
+ 
+  toEnum c =
+    case c of
+      0 -> REGCLS_SINGLEUSE
+      1 -> REGCLS_MULTIPLEUSE
+      2 -> REGCLS_MULTI_SEPARATE
+      4 -> REGCLS_SUSPENDED
+      8 -> REGCLS_SURROGATE
+ 
+
+foreign import ccall "mkEvent" mkEvent :: IO (Ptr ())
+
+foreign import ccall "signalEvent" signalEvent :: Ptr () -> IO ()
+
+foreign import ccall "waitForEvent" waitForEvent :: Ptr () -> IO ()
+
+foreign import stdcall "CoRevokeClassObject"
+	coRevokeClassObject :: Word32 -> IO HRESULT
+
+
+ System/Win32/Com/Server/StdDispatch.hs view
@@ -0,0 +1,493 @@+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Win32.Com.Server.StdDispatch
+-- 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
+--
+-- Implementation of IDispatch in Haskell; pretty useful
+-- when creating\/registering dynamic, on-the-fly event
+-- sinks.
+-- 
+-----------------------------------------------------------------------------
+module System.Win32.Com.Server.StdDispatch
+	( createStdDispatchVTBL
+        , createStdDispatchVTBL2
+	
+	, createStdDispatch
+
+        , DispMethod(..)
+
+	, inArg
+	, inIUnknownArg
+	, inoutArg
+	, outArg
+	, retVal
+
+	, apply_0
+	, apply_1
+	, apply_2
+	, apply_3
+	, apply_4
+	, apply_5
+	, apply_6
+	, apply_7
+
+	, mkDispMethod
+	, dispmethod_0_0
+	, dispmethod_1_0
+	, dispmethod_2_0
+	, dispmethod_3_0
+
+	, dispmethod_0_1
+	, dispmethod_0_2
+
+	) where
+
+import System.Win32.Com.Automation.TypeLib hiding (DISPID,invoke, getIDsOfNames)
+import System.Win32.Com.Server
+import System.Win32.Com
+import System.Win32.Com.Automation
+import System.Win32.Com.HDirect.HDirect
+
+import Foreign.Ptr
+import Foreign.Storable
+import System.Win32.Com.Exception
+import System.Win32.Com.HDirect.WideString
+import Data.Bits
+import System.IO.Unsafe
+import Data.IORef ( newIORef, readIORef, writeIORef )
+import Data.Int
+import Data.List ( find )
+
+
+createStdDispatch :: objState
+		  -> IO ()
+                  -> [DispMethod objState]
+		  -> IID (IUnknown iid)
+		  -> IO (IUnknown iid)
+createStdDispatch objState final meths iid = do
+  vtbl <- createStdDispatchVTBL2 meths
+  createComInstance "" objState final
+                       [ mkIface iid vtbl
+		       , mkIface iidIDispatch vtbl
+		       ]
+		       iid
+
+{-
+This presents a simple, no-fuss implementation of a custom
+IDispatch interface. It takes care of the minutiae of
+implementing IDispatch, but leaves the programmer with the
+task of specifying the instance specific bits of: mapping
+from method names to DISPIDs + the invocation function which
+performs the action associated with a particular DISPID,
+including the marshaling and unmarshaling of VARIANT args.
+
+Abstractions with varying degress of sophistication can be
+layered on top of this basic IDispatch impl - see 
+<tt/createStdDispatchVTBL2/ for one way of doing this.
+-}
+
+createStdDispatchVTBL :: (String -> Maybe DISPID)
+                      -> (DISPID -> MethodKind -> [VARIANT] -> objState -> IO (Maybe VARIANT))
+	              -> IO (ComVTable (IDispatch iid) objState)
+createStdDispatchVTBL meths fun = do
+  a_getTypeInfoCount <- export_getTypeInfoCount getTypeInfoCount_none
+  a_getTypeInfo	     <- export_getTypeInfo      getTypeInfo_none
+  a_getIDsOfNames    <- export_getIDsOfNames	(getIDsOfNames meths)
+  a_invoke	     <- export_invoke		(invoke fun)
+  createComVTable 
+           [ a_getTypeInfoCount
+	   , a_getTypeInfo
+	   , a_getIDsOfNames
+	   , a_invoke
+	   ]
+
+{-
+evDisp = 
+{-
+  simpleDisp mapDISPIDs
+             invokeDISPIDs
+-}
+  simpleDisp2 
+     [ dispmethod_0_0 "DownloadComplete" 1 onDownloadComplete
+     , dispmethod_0_0 "DownloadBegin"    2 onDownloadBegin
+     ]
+ where
+  mapDISPIDs x =
+    case x of
+	  "DownloadComplete" -> Just 1
+	  "DownloadBegin"    -> Just 2
+	  "ProgressChange"   -> Just 3
+	  _                  -> Nothing
+
+  invokeDISPIDs st d mk args =
+    case d of
+	  1 -> st # onDownloadComplete
+	  2 -> st # onDownloadBegin
+	  3 -> st # onProgressChange
+	  _ -> return Nothing -- silently ignore.
+-}
+	  
+data DispMethod objState
+  = DispMethod {
+       disp_method_name :: String,     -- method name
+       disp_method_id   :: DISPID,     -- its ...
+       disp_method_kind :: MethodKind, -- bit of a misnomer.
+       disp_method_act  :: ([VARIANT] -> objState -> IO (Maybe VARIANT))
+    }
+
+mkDispMethod :: String
+             -> DISPID
+	     -> ([VARIANT] -> objState -> IO (Maybe VARIANT))
+	     -> DispMethod objState
+mkDispMethod nm d f = DispMethod nm d Method f
+
+dispmethod_0_0 :: String -> DISPID -> (objState -> IO ()) -> DispMethod objState
+dispmethod_0_0 name id f 
+  = DispMethod name id Method (apply_0 f)
+dispmethod_1_0 name id f 
+  = DispMethod name id Method (inArg $ \ x -> apply_0 (f x))
+dispmethod_2_0 name id f 
+  = DispMethod name id Method 
+               (inArg $ \ x -> inArg $ \ y -> apply_0 (f x y))
+dispmethod_3_0 name id f 
+  = DispMethod name id Method 
+               (inArg $ \ x -> inArg $ \ y -> inArg $ \ z -> apply_0 (f x y z))
+
+dispmethod_0_1 name id f 
+  = DispMethod name id Method
+               (outArg $ \ ret_x -> apply_1 f ret_x)
+
+dispmethod_0_2 name id f 
+  = DispMethod name id Method
+               (outArg $ \ ret_x -> outArg $ \ ret_y -> apply_2 f ret_x ret_y)
+
+-- and so on..
+
+createStdDispatchVTBL2 :: [DispMethod objState]
+                       -> IO (ComVTable (IDispatch iid) objState)
+createStdDispatchVTBL2 assoc = createStdDispatchVTBL lookup_dispid invoke_meths
+ where
+  lookup_dispid m_nm = 
+    case (find ((==m_nm).disp_method_name) assoc) of
+	  Nothing      -> Nothing
+	  Just d       -> Just (disp_method_id d)
+
+  invoke_meths did mkind args obj_st = 
+     case (find ((==did).disp_method_id) assoc) of
+	   Nothing      -> return Nothing
+	   Just d       -> (disp_method_act d) args obj_st
+
+{-
+When using <tt/createStdDispatchVTBL2/, here's a couple
+of helper functions to let you wrap up 
+
+  HRESULT f([in]int i,[in,out]int* j,[out]int* pres, [out,retval]int* retval);
+
+ as
+
+   wrap_f = 
+    inArg     $ \ i       ->
+    inArg     $ \ j j_out ->
+    resArg    $ \ pres    ->
+    retVal    $ \ retval  ->
+    apply_3 (f i j) j_out pres retval
+-}
+inArg :: ( Variant a )
+      => (a -> [VARIANT] -> objState -> IO b)
+      -> [VARIANT]
+      -> objState
+      -> IO b
+inArg cont (a:args) objState = do
+   x <- resVariant a
+   cont x args objState
+
+inIUnknownArg :: (IUnknown a -> [VARIANT] -> objState -> IO b)
+              -> [VARIANT]
+              -> objState
+              -> IO b
+inIUnknownArg cont (a:args) objState = do
+   x <- resIUnknown a
+   cont x args objState
+
+inoutArg :: ( Variant a, Variant b )
+         => ( a -> (b -> IO ()) -> [VARIANT] -> objState -> IO c)
+         -> [VARIANT]
+         -> objState
+         -> IO c
+inoutArg cont (a:args) objState = do
+   x <- resVariant a
+   cont x (\ x -> inVariant x a) args objState
+
+outArg    :: ( Variant a )
+	  => ((a -> IO ()) -> [VARIANT] -> objState -> IO b)
+          -> [VARIANT]
+	  -> objState
+	  -> IO b
+outArg cont (a:args) objState = cont (\ x -> inVariant x a) args objState
+
+retVal  :: ( Variant a )
+        => ((a -> IO ()) -> [VARIANT] -> objState -> IO (Maybe VARIANT))
+	-> [VARIANT]
+	-> objState
+	-> IO (Maybe VARIANT)
+retVal cont args objState = do
+   -- what a hack.
+  res_ref <- newIORef Nothing
+  cont (\ x -> writeIORef res_ref (Just x)) args objState 
+  retv <- readIORef res_ref
+  case retv of
+    Nothing -> return Nothing
+    Just x  -> do
+      pVarResult <- allocBytes (fromIntegral sizeofVARIANT)
+      inVariant x pVarResult
+      return (Just pVarResult)
+
+apply_0 :: (objState -> IO ())
+        -> [VARIANT]
+        -> objState
+        -> IO (Maybe VARIANT)
+apply_0 f _ objState = f objState >> return Nothing
+
+apply_1 :: (Variant a)
+        => (objState -> IO a)
+	-> (a -> IO ())
+        -> [VARIANT]
+	-> objState
+	-> IO (Maybe VARIANT)
+apply_1 f res_1 _ objState = do
+   x <- f objState
+   res_1 x
+   return Nothing
+
+apply_2 :: (Variant a0, Variant a1)
+        => (objState -> IO (a0,a1))
+	-> (a0 -> IO ())
+	-> (a1 -> IO ())
+        -> [VARIANT]
+	-> objState
+	-> IO (Maybe VARIANT)
+apply_2 f res_1 res_2 _ objState = do
+   (x,y) <- f objState
+   res_1 x
+   res_2 y
+   return Nothing
+
+apply_3 :: (Variant a0, Variant a1, Variant a2)
+        => (objState -> IO (a0,a1,a2))
+	-> (a0 -> IO ())
+	-> (a1 -> IO ())
+	-> (a2 -> IO ())
+        -> [VARIANT]
+	-> objState
+	-> IO (Maybe VARIANT)
+apply_3 f res_1 res_2 res_3 _ objState = do
+   (a0,a1,a2) <- f objState
+   res_1 a0
+   res_2 a1
+   res_3 a2
+   return Nothing
+
+apply_4 :: (Variant a0, Variant a1, Variant a2, Variant a3)
+        => (objState -> IO (a0,a1,a2,a3))
+	-> (a0 -> IO ())
+	-> (a1 -> IO ())
+	-> (a2 -> IO ())
+	-> (a3 -> IO ())
+        -> [VARIANT]
+	-> objState
+	-> IO (Maybe VARIANT)
+apply_4 f res_1 res_2 res_3 res_4 _ objState = do
+   (a0,a1,a2,a3) <- f objState
+   res_1 a0
+   res_2 a1
+   res_3 a2
+   res_4 a3
+   return Nothing
+
+apply_5 :: (Variant a0, Variant a1, Variant a2, Variant a3, Variant a4)
+        => (objState -> IO (a0,a1,a2,a3,a4))
+	-> (a0 -> IO ())
+	-> (a1 -> IO ())
+	-> (a2 -> IO ())
+	-> (a3 -> IO ())
+	-> (a4 -> IO ())
+        -> [VARIANT]
+	-> objState
+	-> IO (Maybe VARIANT)
+apply_5 f res_1 res_2 res_3 res_4 res_5 _ objState = do
+   (a0,a1,a2,a3,a4) <- f objState
+   res_1 a0
+   res_2 a1
+   res_3 a2
+   res_4 a3
+   res_5 a4
+   return Nothing
+
+apply_6 :: (Variant a0, Variant a1, Variant a2, Variant a3, Variant a4, Variant a5)
+        => (objState -> IO (a0,a1,a2,a3,a4,a5))
+	-> (a0 -> IO ())
+	-> (a1 -> IO ())
+	-> (a2 -> IO ())
+	-> (a3 -> IO ())
+	-> (a4 -> IO ())
+	-> (a5 -> IO ())
+        -> [VARIANT]
+	-> objState
+	-> IO (Maybe VARIANT)
+apply_6 f res_1 res_2 res_3 res_4 res_5 res_6 _ objState = do
+   (a0,a1,a2,a3,a4,a5) <- f objState
+   res_1 a0
+   res_2 a1
+   res_3 a2
+   res_4 a3
+   res_5 a4
+   res_6 a5
+   return Nothing
+
+apply_7 :: (Variant a0, Variant a1, Variant a2, Variant a3, Variant a4, Variant a5, Variant a6)
+        => (objState -> IO (a0,a1,a2,a3,a4,a5,a6))
+	-> (a0 -> IO ())
+	-> (a1 -> IO ())
+	-> (a2 -> IO ())
+	-> (a3 -> IO ())
+	-> (a4 -> IO ())
+	-> (a5 -> IO ())
+	-> (a6 -> IO ())
+        -> [VARIANT]
+	-> objState
+	-> IO (Maybe VARIANT)
+apply_7 f res_1 res_2 res_3 res_4 res_5 res_6 res_7 _ objState = do
+   (a0,a1,a2,a3,a4,a5,a6) <- f objState
+   res_1 a0
+   res_2 a1
+   res_3 a2
+   res_4 a3
+   res_5 a4
+   res_6 a5
+   res_7 a6
+   return Nothing
+
+type ThisPtr a = Ptr a
+
+invoke :: (DISPID -> MethodKind -> [VARIANT] -> objState -> IO (Maybe VARIANT))
+       -> Ptr (IDispatch ())
+       -> DISPID
+       -> Ptr (IID ())
+       -> LCID
+       -> Word32
+       -> Ptr (Ptr ()) --DISPPARAMS
+       -> Ptr VARIANT
+       -> Ptr (Ptr ()) --EXCEPINFO
+       -> Ptr Word32
+       -> IO HRESULT
+invoke dispMeth this dispIdMember riid lcid wFlags pDispParams
+       pVarResult pExcepInfo puArgErr = do
+   iid <- unmarshallIID False riid
+   if (iid /= iidNULL) then
+      return dISP_E_UNKNOWNINTERFACE
+    else do
+      let mkind = toMethodKind wFlags
+          args  = unsafePerformIO (unmarshallArgs (castPtr pDispParams))
+      st  <- getObjState this
+      catch (do
+        res <- dispMeth dispIdMember mkind args st
+        case res of 
+          Nothing -> do
+	    if pVarResult == nullPtr then
+	       return ()
+	     else
+ 	       poke pVarResult nullPtr
+          Just x  -> do
+--           putMessage ("Invoke: " ++ show dispIdMember ++ " interested")
+	    writeVARIANT pVarResult x
+        return s_OK) 
+       (\ err -> 
+          case coGetErrorHR err of
+	    Nothing -> do
+	      if pExcepInfo == nullPtr then
+	         return dISP_E_EXCEPTION
+	       else do
+	         poke (castPtr pExcepInfo) nullPtr
+		 return dISP_E_EXCEPTION
+	    Just hr ->
+	      -- ToDo: a lot better.
+	      if pExcepInfo == nullPtr then
+	         return hr
+	       else do
+	         poke (castPtr pExcepInfo) nullPtr
+		 return hr)
+	      
+
+unmarshallArgs :: Ptr DISPPARAMS -> IO [VARIANT]
+unmarshallArgs ptr 
+  | ptr == nullPtr = return []
+  | otherwise       = do
+     dp <- readDISPPARAMS (castPtr ptr)
+     case dp of
+       (TagDISPPARAMS rs _) -> return rs
+
+
+data MethodKind = Method | PropertyGet | PropertyPut
+
+toMethodKind :: Word32 -> MethodKind
+toMethodKind x
+  | x .&. dISPATCH_METHOD         /= 0 = Method
+  | x .&. dISPATCH_PROPERTYGET    /= 0 = PropertyGet
+  | x .&. dISPATCH_PROPERTYPUT    /= 0 = PropertyPut
+  | x .&. dISPATCH_PROPERTYPUTREF /= 0 = PropertyPut
+  | otherwise			       = Method
+
+dISPATCH_METHOD :: Word32
+dISPATCH_METHOD = 0x1
+dISPATCH_PROPERTYGET :: Word32
+dISPATCH_PROPERTYGET = 0x2
+dISPATCH_PROPERTYPUT :: Word32
+dISPATCH_PROPERTYPUT = 0x4
+dISPATCH_PROPERTYPUTREF :: Word32
+dISPATCH_PROPERTYPUTREF = 0x8
+
+getIDsOfNames :: (String -> Maybe DISPID)
+	      -> ThisPtr (IDispatch ())
+	      -> Ptr (IID ())
+	      -> Ptr WideString
+	      -> Word32
+	      -> LCID
+	      -> Ptr DISPID
+	      -> IO HRESULT
+getIDsOfNames lookup_dispid this riid rgszNames cNames lcid rgDispID
+  | cNames /= 1 = return e_FAIL
+  | otherwise   = do
+      pwide     <- peek (castPtr rgszNames)
+      (pstr,hr) <- wideToString pwide
+      checkHR hr
+      str       <- unmarshallString (castPtr pstr)
+      case lookup_dispid str of
+        Nothing -> return e_FAIL
+	Just v  -> do
+	   writeInt32 rgDispID v
+	   return s_OK
+
+{-
+We don't expose type information of any sort, so 
+here's the negative versions of the two IDispatch
+methods.
+-}
+
+getTypeInfoCount_none :: Ptr () -> Ptr Word32 -> IO HRESULT
+getTypeInfoCount_none iptr pctInfo = do
+  writeWord32 pctInfo 0
+  return s_OK
+
+getTypeInfo_none :: Ptr (IDispatch ()) -> Word32 -> LCID -> Ptr () -> IO HRESULT
+getTypeInfo_none this iTInfo lcid ppTInfo
+  | iTInfo /= 0         = return tYPE_E_ELEMENTNOTFOUND
+  | ppTInfo == nullPtr = return e_POINTER
+  | otherwise		= do
+     poke (castPtr ppTInfo) nullPtr
+     return s_OK
+
+ cbits/AutoPrimSrc.c view
@@ -0,0 +1,591 @@+/*-----------------------------------------------------------
+ (c) 1998,  Daan Leijen, leijen@@fwi.uva.nl
+     1999-, Sigbjorn Finne sof@galconn.com
+
+  Changes:
+    * made cygwin32 (&gcc) friendly.
+        -- sof 10/98
+-----------------------------------------------------------*/
+
+
+#if !defined(__CYGWIN32__) && !defined(__MINGW32__)
+#define CINTERFACE
+#define COBJMACROS
+#endif
+#include <windows.h>
+#include <stdio.h>
+
+#if defined(__CYGWIN32__) || defined(__MINGW32__)
+#include <w32api.h>
+#endif
+
+#ifdef __GNUC__
+#include "comPrim.h"
+#include "autoPrim.h"
+#include "PointerSrc.h"
+#include <stdlib.h>
+#include <string.h>
+
+/* No support for nameless unions..yet. */
+#if __W32API_MAJOR_VERSION == 1
+#define cyVal n1.n2.n3.cyVal
+#define bVal n1.n2.n3.bVal
+#define punkVal n1.n2.n3.punkVal
+#define boolVal n1.n2.n3.boolVal
+#define pdispVal n1.n2.n3.pdispVal
+#define bstrVal  n1.n2.n3.bstrVal
+#define date     n1.n2.n3.date
+#define dblVal   n1.n2.n3.dblVal
+#define fltVal   n1.n2.n3.fltVal
+#define lVal     n1.n2.n3.lVal
+#define ulVal    n1.n2.n3.ulVal
+#define iVal     n1.n2.n3.iVal
+#define parray   n1.n2.n3.parray
+#define pparray  n1.n2.n3.pparray
+#define decVal   n1.decVal
+#define vt       n1.n2.vt
+#endif
+#endif
+
+/*-----------------------------------------------------------
+-- Invoke
+-----------------------------------------------------------*/
+
+HRESULT dispatchInvoke( IDispatch* obj, DISPID dispid, LCID lcid,
+                        BOOL isfunction, unsigned flags,
+                        int cargs, int cargsout,
+                        VARIANT* args, VARIANT* argsout,
+                        EXCEPINFO** info )
+{
+   HRESULT      hr;
+   DISPPARAMS   dp;
+   EXCEPINFO    excepInfo;
+   UINT         argErr;
+   VARIANT      varRes;
+   VARIANT*     res;
+   DISPID       dispput;
+   int          i;
+
+
+   if (info) *info = NULL;
+
+   /* create VT_BYREF variants for out parameters */
+   for (i = 0; i < cargsout; i++)
+   {
+        VariantInit( args+i );
+        args[i].vt    = argsout[i].vt | VT_BYREF;
+#if !defined(__GNUC__) || __W32API_MAJOR_VERSION > 1
+        args[i].byref = &(argsout[i].byref);
+#else
+        args[i].n1.n2.n3.byref = &(argsout[i].n1.n2.n3.byref);
+#endif
+   }
+
+   if (!obj) return E_POINTER;
+
+   dp.cArgs  = cargs;
+   dp.rgvarg = args;
+
+   /* set special flags for property puts */
+   if (flags & DISPATCH_PROPERTYPUT)
+   {
+     dispput = DISPID_PROPERTYPUT;
+     dp.rgdispidNamedArgs = &dispput;
+     dp.cNamedArgs = 1;
+   }
+   else
+   {
+     dp.rgdispidNamedArgs = NULL;
+     dp.cNamedArgs = 0;
+   }
+
+   /* if this is surely a function, return the
+      result in the first element of argsout, and
+      decrement the number of arguments */
+   if (isfunction)
+   {
+      dp.cArgs--;
+      dp.rgvarg++;
+      res = argsout;
+   }
+   else
+   {
+      res = &varRes;
+      VariantInit(res);
+   }
+
+   hr = IDispatch_Invoke( obj, dispid, &IID_NULL, lcid, flags,
+                          &dp, res, &excepInfo, &argErr );
+
+   /* if guessed that this was not a function, but it returned
+      a result (in varRes) or it complained about the number
+      of arguments, than we again try to call it but now as a function. */
+
+   /* Turned this smart off, leaving it to HDirect (and the user) to
+      make the distinction between memberX and functionX.  -- sof
+      
+      No, let's not -- sometimes the type information isn't precise
+      enough about this (e.g., the type info for msi.dll's
+      Installer.OpenDatabase() suggests its a _method_, but it turns
+      out to be a _function_.
+   */
+   if (!isfunction && flags == DISPATCH_METHOD &&
+       (hr == DISP_E_BADPARAMCOUNT || 
+        hr == DISP_E_TYPEMISMATCH  ||
+	res->vt != VT_EMPTY) ) {
+       isfunction = TRUE;
+       dp.cArgs--;
+       dp.rgvarg++;
+       VariantClear(res);
+       res = argsout;
+
+       hr = IDispatch_Invoke( obj, dispid, &IID_NULL, lcid, flags,
+                          &dp, res, &excepInfo, &argErr );
+   }
+   if (!isfunction)
+        VariantClear( res );
+
+   /* free the input arguments */
+   for (i = cargsout; i < cargs; i++)
+        VariantClear( args+i );
+
+   /* check for exceptions */
+   if (hr == DISP_E_EXCEPTION && info)
+   {
+       *info = (EXCEPINFO*)primAllocMemory( sizeof(EXCEPINFO));
+       if (*info)
+       {
+          **info = excepInfo;
+          if ((*info)->pfnDeferredFillIn)
+              (*info)->pfnDeferredFillIn( *info );
+       }
+   }
+   return hr;
+}
+
+void freeExcepInfo( EXCEPINFO* info )
+{
+   if (!info) return;
+
+   if (info->bstrSource)        SysFreeString( info->bstrSource );
+   if (info->bstrDescription)   SysFreeString( info->bstrDescription );
+   if (info->bstrHelpFile)      SysFreeString( info->bstrHelpFile );
+}
+
+char* getExcepInfoMessage( EXCEPINFO* info )
+{
+#define    MAXMSG       255
+#define    MAXSTR       80
+
+    char member[MAXSTR+1] = "";
+    char source[MAXSTR+1] = "";
+    char wcode[MAXSTR+1]  = "";
+    char description[MAXMSG+1] = "Exception occurred";
+    char* msg;
+
+    msg = primAllocMemory( MAXMSG+1 );
+    if (!msg) return NULL;
+
+    if (info)
+    {
+      if (info->bstrSource)
+      {
+         char sourceReg[MAXSTR];
+
+         wcstombs( sourceReg, info->bstrSource, MAXSTR );
+         if (ERROR_SUCCESS !=
+                           RegQueryValueA( HKEY_CLASSES_ROOT, sourceReg, source, NULL ))
+             wcstombs( source, info->bstrSource, MAXSTR );
+      }
+
+      if (info->wCode)
+      {
+	 sprintf( wcode, "(%d)", info->wCode );
+      }
+      
+      if (info->bstrDescription)
+      {   
+         wcstombs( description, info->bstrDescription, MAXMSG);
+      }
+      else if (info->scode)
+      {
+         strncpy( description, hresultString(info->scode), MAXMSG );
+      }
+   }
+
+   if (info && info->bstrSource)
+#ifdef __GNUC__
+      sprintf(msg, "%s.%s:%s %s", source, member, wcode, description);
+#else
+      _snprintf( msg, MAXMSG, "%s.%s:%s %s",
+                            source,member,wcode,description);
+#endif
+   else
+#ifdef __GNUC__
+      sprintf(msg, "%s %s", wcode, description);
+#else
+      _snprintf( msg, MAXMSG, "%s %s", wcode,description);
+#endif
+ 
+   return msg;
+}
+
+HRESULT dispatchGetMemberID( IDispatch* obj,
+                             BSTR name, LCID lcid, DISPID* dispid )
+{
+   if (obj) return IDispatch_GetIDsOfNames( obj, &IID_NULL,
+                                             &name, 1, lcid, dispid );
+       else return E_POINTER;
+}
+
+
+/*-----------------------------------------------------------
+-- Variant marshalling (we just lack VT_ARRAY support)
+-----------------------------------------------------------*/
+
+void freeVariants( int count, VARIANT* p )
+{
+   int i;
+   if (!p) return;
+   for (i = 0; i < count; i++)
+      VariantClear(p+i);
+}
+
+int readVariantTag(VARIANT* pw) { return(pw->vt); }
+
+#define READWRITEVAR(htp,ctp,tp,fld,def) \
+                                void writeVar##htp( ctp x, VARIANT* v )   \
+                                {                                       \
+                                   WRITEVAR(tp,fld);                     \
+                                }  \
+                                HRESULT readVar##htp( VARIANT* v, ctp* p ) \
+                                { \
+                                   READVAR(tp,fld,def); \
+                                }
+
+#define WRITEVAR(tp,fld)     {  if (!v) return; \
+                                VariantInit(v); \
+                                v->vt = tp; \
+                                v->fld = x; \
+                             }
+
+#define READVAR(tp,fld,def)  {  if (!p) return E_POINTER; \
+                                if (!v) { *p = def; return E_POINTER;} \
+                                if (v->vt == tp) {      \
+                                  *p = v->fld;          \
+                                  return S_OK;          \
+                                } else {                \
+                                  VARIANT w;            \
+                                  HRESULT hr;           \
+                                  VariantInit( &w );    \
+                                  hr = VariantChangeType( &w, v, 0, tp ); \
+                                  if (SUCCEEDED(hr)) *p = w.fld; \
+                                                else *p = def;   \
+                                  return hr;            \
+                              }                         \
+                            }
+
+
+#define READWRITETEMPVAR(htp,ctp,tp,fld,def) \
+                                void writeVar##htp( ctp x, VARIANT* v )   \
+                                {                                       \
+                                   WRITEVAR(tp,fld);                     \
+                                }  \
+                                HRESULT readVar##htp( VARIANT* v, ctp* p, VARIANT** w ) \
+                                { \
+                                   READTEMPVAR(tp,fld,def); \
+                                }
+
+
+#define READTEMPVAR(tp,fld,def) { if (w) *w = NULL;     \
+                                if (!p) return E_POINTER; \
+                                if (!v) { *p = def; return E_POINTER; } \
+                                if (v->vt == tp) {      \
+                                  *p = v->fld;          \
+                                  return S_OK;          \
+                                } else {                \
+                                  HRESULT hr;           \
+                                  *p = def;             \
+                                  if (!w) return E_POINTER; \
+                                  *w = primAllocMemory( sizeof(VARIANT)); \
+                                  if (*w == NULL) return E_OUTOFMEMORY;  \
+                                  VariantInit( *w );    \
+                                  hr = VariantChangeType( *w, v, 0, tp ); \
+                                  if (SUCCEEDED(hr)) *p = (*w)->fld; \
+                                                else { primFreeMemory(*w); *w = NULL; } \
+                                  return hr;            \
+                              }                         \
+                            }
+
+
+READWRITEVAR( Short, int, VT_I2, iVal, 0 )
+READWRITEVAR( Int, int, VT_I4, lVal, 0 )
+READWRITEVAR( Word, unsigned int, VT_UI4, ulVal, 0 )
+READWRITEVAR( Float, float, VT_R4, fltVal, 0.0 )
+READWRITEVAR( Double, double, VT_R8, dblVal, 0.0 )
+READWRITEVAR( Date, double, VT_DATE, date, 0.0 )
+READWRITETEMPVAR( String, BSTR, VT_BSTR, bstrVal, NULL )
+READWRITETEMPVAR( Dispatch, IDispatch*, VT_DISPATCH, pdispVal, NULL )
+READWRITEVAR( Bool, BOOL, VT_BOOL, boolVal, 0 )
+READWRITETEMPVAR( Unknown, IUnknown*, VT_UNKNOWN, punkVal, NULL )
+READWRITEVAR( Byte, unsigned char, VT_UI1, bVal, 0 )
+#if __W32API_MAJOR_VERSION == 1
+READWRITEVAR( Error, int, VT_ERROR, n1.n2.n3.scode, 0 )
+#else
+READWRITEVAR( Error, int, VT_ERROR, scode, 0 )
+#endif
+
+void
+writeVarOptional( VARIANT * v )
+{
+  if (!v) return;
+  VariantInit ( v );
+  v->vt       = VT_ERROR;
+#if __W32API_MAJOR_VERSION == 1
+  v->n1.n2.n3.scode = DISP_E_PARAMNOTFOUND;
+#else
+  v->scode = DISP_E_PARAMNOTFOUND;
+#endif
+
+}
+
+/* ToDo: readVarOptional */
+
+void 
+writeVarSAFEARRAY( VARIANT* v, SAFEARRAY* sa, VARTYPE ovt )
+{
+  if (!v) return;
+  VariantInit(v);
+  v->vt     = VT_ARRAY | ovt;
+  v->parray = sa;
+}
+
+HRESULT
+readVarSAFEARRAY( VARIANT* v, SAFEARRAY** sa, VARTYPE ovt)
+{
+  if (!v) return E_POINTER;
+  if (v->vt & VT_ARRAY || v->vt == VT_SAFEARRAY) {
+    /* Will return same pointer, but let's follow the rules. */
+    if (v->vt & VT_BYREF) {
+      *sa = *(v->pparray);
+    } else {
+      *sa = v->parray;
+    }
+    return S_OK;
+  } else {
+        VARIANT w;
+        HRESULT hr;
+
+        VariantInit(&w);
+        hr = VariantChangeType( &w, v, 0, VT_ARRAY | ovt);
+        if (SUCCEEDED(hr)) {
+           *sa = w.parray;
+        } else  {
+	   *sa = NULL;
+        }
+        return hr;
+  }
+}
+
+/* VT_EMPTY, VT_NULL, VT_CY, VT_VARIANT */
+
+void writeVarEmpty( VARIANT* v )
+{
+   if (!v) return;
+   VariantInit( v );
+   v->vt = VT_EMPTY;
+}
+
+/* readEmpty; succeeds always */
+
+void writeVarNull( VARIANT* v )
+{
+   if (!v) return;
+   VariantInit( v );
+   v->vt = VT_NULL;
+}
+
+HRESULT readVarNull( VARIANT* v )
+{
+  if (!v) return E_POINTER;
+  if (v->vt == VT_NULL)
+        return S_OK;
+  else
+  {
+        VARIANT w;
+        VariantInit( &w );
+        return VariantChangeType( &w, v, 0, VT_NULL );
+  }
+}
+
+void writeVarCurrency( int hi, unsigned int lo, VARIANT* v )
+{
+   if (!v) return;
+   VariantInit(v);
+   v->vt = VT_CY;
+   v->cyVal.Hi  = hi;
+   v->cyVal.Lo  = lo;
+}
+
+HRESULT readVarCurrency( VARIANT* v, int* hi, int* lo )
+{
+   if (!v) return E_POINTER;
+   if (!hi) return E_POINTER;
+   if (!lo) return E_POINTER;
+
+   if (v->vt == VT_CY)
+   {
+        *hi = v->cyVal.Hi;
+        *lo = v->cyVal.Lo;
+        return S_OK;
+   }
+   else
+   {
+        VARIANT w;
+        HRESULT hr;
+
+        VariantInit(&w);
+        hr = VariantChangeType( &w, v, 0, VT_CY);
+        if (SUCCEEDED(hr))
+        {
+                *hi = w.cyVal.Hi;
+                *lo = w.cyVal.Lo;
+        }
+        else
+        {
+                *hi = *lo = 0;
+        }
+        return hr;
+   }
+}
+
+void writeVarWord64( unsigned int hi, unsigned int lo, VARIANT* v )
+{
+   ULONGLONG r;
+
+   r = (ULONGLONG)hi;
+   r >>= 32;
+   r += (ULONGLONG)lo;
+
+   if (!v) return;
+   VariantInit(v);
+   v->vt = VT_DECIMAL;
+   v->decVal.Lo64  = r;
+   v->decVal.Hi32  = 0;
+   v->decVal.sign  = 0;
+   v->decVal.scale = 0;
+}
+
+HRESULT readVarWord64( VARIANT* v, unsigned int* hi, unsigned int* lo )
+{
+   ULONGLONG r;
+
+   if (!v) return E_POINTER;
+   if (!hi) return E_POINTER;
+   if (!lo) return E_POINTER;
+
+   if (v->vt == VT_DECIMAL)
+   {
+        r   = v->decVal.Lo64;
+	*lo = (unsigned long)r;
+	r   <<= 32;
+	*hi = (unsigned long)r;
+        return S_OK;
+   }
+   else
+   {
+        VARIANT w;
+        HRESULT hr;
+
+        VariantInit(&w);
+        hr = VariantChangeType( &w, v, 0, VT_DECIMAL);
+        if (SUCCEEDED(hr))
+        {
+	        r   = v->decVal.Lo64;
+	        *lo = (unsigned long)r;
+	        r   <<= 32;
+	        *hi = (unsigned long)r;
+        }
+        else
+        {
+                *hi = *lo = 0;
+        }
+        return hr;
+   }
+}
+
+
+void writeVarVariant( VARIANT* x, VARIANT* v)
+{
+   if (!v) return;
+   if (!x) return;
+
+   VariantInit(v);
+   VariantCopy( v, x );
+}
+
+HRESULT readVarVariant( VARIANT* v, VARIANT* x )
+{
+   if (!v)  return E_POINTER;
+   if (!x)  return E_POINTER;
+
+   VariantInit(x);
+   return VariantCopy( x, v );
+}
+
+/* 
+   First VARIANT* is uninitialised chunk of memory.
+   Initialise and copy the second one into it.
+*/
+HRESULT
+primCopyVARIANT ( VARIANT* p1
+                , VARIANT* p2
+		)
+{
+  VariantInit(p1);
+  return (VariantCopy(p1,p2));
+}
+
+HRESULT
+primVARIANTClear ( VARIANT* p1 )
+{
+  return VariantClear(p1);
+}
+
+/*
+ * Converting a time_t to date/time representation used by
+ * Automation.
+ */
+HRESULT
+primClockToDate (int t, double *pt) 
+{
+  FILETIME ft;
+  SYSTEMTIME st;
+  LONGLONG l = Int32x32To64(t, 10000000) + 116444736000000000ULL;
+
+  ft.dwLowDateTime = (DWORD) l;
+  ft.dwHighDateTime = l >>32;
+  
+  if (!FileTimeToSystemTime(&ft,&st)) {
+    return E_FAIL;
+  }
+  
+#if ( (!defined(__MINGW32__) && !defined(__CYGWIN__)) || \
+       (__W32API_MAJOR_VERSION >= 1 && \
+         (__W32API_MAJOR_VERSION > 1 || __W32API_MINOR_VERSION >= 1)) )
+  /* If on a non-gnuwin platform or on one with a w32api version
+     that's 1.1 or greater.
+  */
+  if (!SystemTimeToVariantTime(&st, pt)) {
+    return E_FAIL;
+  }
+  return S_OK;
+#else
+  /* SystemTimeToVariantTime() isn't provided in the oleaut32
+     import library until w32api 1.1 (or thereabouts, haven't 
+     exactly pinpointed when this bug fixed).
+   */
+  return E_FAIL;
+#endif
+  
+}
+ cbits/ComPrimSrc.c view
@@ -0,0 +1,604 @@+/* #define DEBUG */
+
+/* If you don't want the 'stack' allocator, comment this out */
+/* #define USESTACK */
+
+#ifndef COM
+#define COM
+#endif
+
+/* define the DLL export macro */
+#if defined(_WIN32) && !defined(__CYGWIN32__) && !defined(__MINGW32__)
+#define DLLEXPORT(res)  __declspec(dllexport) res
+#else
+/* redef this default for your system */
+#define DLLEXPORT(res)  extern res
+#endif
+
+
+#ifdef COM
+#define COBJMACROS
+#define CINTERFACE
+#endif
+
+#include <stdio.h>
+
+#ifdef _MSC_VER
+#include <windows.h>
+#else
+#include <stdlib.h>
+#include "comPrim.h"
+#include "PointerSrc.h"
+#endif
+
+#define MAXSZ 255
+
+const IID IID_NULL = {0x00000000L, 0x0000, 0x0000, {0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}};
+#ifndef _MSC_VER
+const IID IID_IUnknown = {0x00000000L, 0x0000, 0x0000, {0xC0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x46}};
+const IID IID_IClassFactory = {0x00000001L, 0x0000, 0x0000, {0xC0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x46}};
+#endif
+
+DLLEXPORT(char*) hresultString( HRESULT hr )
+{
+   static char msgbuf[256];
+   int len;
+
+   sprintf( msgbuf, "(0x%lx) ", hr );
+   len = strlen(msgbuf);
+
+   FormatMessageA(
+        FORMAT_MESSAGE_FROM_SYSTEM,
+        NULL,
+        hr,
+        MAKELANGID(LANG_NEUTRAL, SUBLANG_NEUTRAL),
+        msgbuf + len,
+        256,
+        NULL
+    );
+
+    return msgbuf;
+}
+
+
+HRESULT primStringToGUID( WCHAR* guidStr, GUID* guid )
+{
+   if (guid) return CLSIDFromString( guidStr, guid );
+        else  return E_OUTOFMEMORY;
+}
+
+HRESULT primGUIDToString( CLSID* guid, WCHAR** guidStr )
+{
+   CLSID* rclsid;
+   HRESULT hr;
+
+   rclsid = (CLSID*)guid;
+
+   if (!rclsid)   rclsid = (CLSID*)&IID_NULL;
+   if (guidStr) {
+      hr = StringFromCLSID( rclsid, guidStr  );
+   } else {
+      hr = E_POINTER;
+   }
+   return hr;
+}
+
+HRESULT primProgIDFromCLSID( const CLSID* clsid, WCHAR** clsidStr )
+{
+   if (!clsid)   clsid = &IID_NULL;
+   if (clsidStr) return ProgIDFromCLSID( clsid, clsidStr );
+            else return E_POINTER;
+}
+
+
+/*-----------------------------------------------------------
+-- Com library calls
+-----------------------------------------------------------*/
+
+static int com_already_initialized = 0;
+static int com_already_uninitialized = 0;
+
+HRESULT comInitialize(void)
+{
+   if (!com_already_initialized) {
+      com_already_initialized = 1;
+      return OleInitialize(NULL);
+   } else {
+      return S_OK;
+   }
+   
+}
+
+void shutdown__()
+{
+  OleUninitialize();
+  com_already_initialized = 0;
+  com_already_uninitialized = 0;
+}
+
+void comUnInitialize(void)
+{
+  if (!com_already_uninitialized) {
+     com_already_uninitialized=1;
+     atexit(shutdown__);
+  }
+}
+
+/*-----------------------------------------------------------
+-- Object Creation
+-----------------------------------------------------------*/
+
+/* CLSIDFromProgID is a bit too naive, so I wrote it myself */
+HRESULT primCLSIDFromProgID( const char* progid, CLSID* clsid )
+{
+  HRESULT hr;
+  char  name[MAXSZ];
+  DWORD namesz = MAXSZ;
+  BYTE  value[MAXSZ];
+  DWORD valuesz = MAXSZ;
+  WCHAR clsidName[MAXSZ];
+  DWORD type   = REG_SZ;
+  HKEY  key    = 0;
+  HKEY  subkey = 0;
+
+  if (!clsid)   return E_POINTER;
+  if (!progid)  return E_POINTER;
+
+  hr = HRESULT_FROM_WIN32(RegOpenKeyExA( HKEY_CLASSES_ROOT, progid, 0, KEY_READ, &key ));
+  if (FAILED(hr)) return CO_E_CLASSSTRING;
+
+  hr = HRESULT_FROM_WIN32(RegOpenKeyExA( key, "CurVer", 0, KEY_READ, &subkey ));
+  if (SUCCEEDED(hr))
+  {
+     hr = HRESULT_FROM_WIN32(RegEnumValueA( subkey, 0, name, &namesz, NULL, &type, value, &valuesz));
+     RegCloseKey( key );
+     RegCloseKey( subkey );
+     if (FAILED(hr)) return hr;
+
+     hr = HRESULT_FROM_WIN32(RegOpenKeyExA( HKEY_CLASSES_ROOT, (char*)value, 0, KEY_QUERY_VALUE, &key ));
+     if (FAILED(hr)) return CO_E_CLASSSTRING;
+
+     namesz  = MAXSZ;
+     valuesz = MAXSZ;
+  }
+
+  hr = HRESULT_FROM_WIN32(RegOpenKeyExA( key, "CLSID", 0, KEY_READ, &subkey ));
+  if (FAILED(hr)) { RegCloseKey( key ); return CO_E_CLSREG_INCONSISTENT; };
+
+  hr = HRESULT_FROM_WIN32(RegEnumValueA( subkey, 0, name, &namesz, NULL, &type,value,&valuesz));
+  RegCloseKey( subkey );
+  RegCloseKey( key );
+  if (FAILED(hr)) return hr;
+
+  mbstowcs( clsidName, (char*)value, MAXSZ );
+  hr = CLSIDFromString( clsidName, clsid );
+
+  return hr;
+}
+
+/* Newer COM libraries supply the functionality of
+   bindObject() via CoGetObject(), but to avoid depending
+   on that being around, we stick with our own implementation.
+*/
+HRESULT bindObject( const WCHAR* name, IID* iid, void** unk )
+{
+  HRESULT hr;
+  IBindCtx    *bc;
+  IMoniker    *mk;
+  ULONG        count;
+
+  if (!unk) return E_POINTER;
+       else *unk = NULL;
+  if (!iid) return E_POINTER;
+
+  bc = NULL;
+  mk = NULL;
+
+  hr = CreateBindCtx(0, &bc);
+  if (FAILED(hr)) return hr;
+
+  hr = MkParseDisplayName(bc, name, &count, &mk);
+  if (FAILED(hr)) { IUnknown_Release(bc); return hr; }
+
+  hr = IMoniker_BindToObject( mk, bc, NULL, iid, unk );
+  IUnknown_Release(mk);
+  IUnknown_Release(bc);
+
+  return hr;
+}
+
+typedef HRESULT (__stdcall * qi_methPtrTy)(void*,void*,void**);
+
+HRESULT primQI ( /*[in]*/void*  methPtr
+	       , /*[in]*/void*  iptr
+	       , /*[in]*/void*  riid
+	       , /*[in]*/void** ppv
+	       )
+{
+ return ((qi_methPtrTy)methPtr)(iptr,riid,ppv);
+}
+
+typedef unsigned int (__stdcall * addRef_methPtrTy)(void*);
+ 
+unsigned int
+primAddRef ( /*[in]*/void*  methPtr
+	   , /*[in]*/void*  iptr
+	   )
+{
+ return ((addRef_methPtrTy)methPtr)(iptr);
+}
+
+typedef unsigned int (__stdcall * release_methPtrTy)(void*);
+ 
+unsigned int
+primRelease ( /*[in]*/void*  methPtr
+	    , /*[in]*/void*  iptr
+	    )
+{
+ return ((release_methPtrTy)methPtr)(iptr);
+}
+
+typedef unsigned int (__stdcall * enumNext_methPtrTy)(void* iptr, unsigned int celt, void* ptr, void* po);
+
+HRESULT
+primEnumNext(void* methPtr, void* iptr, unsigned int celt, void* ptr, void* po)
+{
+ return ((enumNext_methPtrTy)methPtr)(iptr,celt,ptr,po);
+
+}
+
+typedef unsigned int (__stdcall * enumSkip_methPtrTy)(void* iptr, unsigned int celt);
+
+HRESULT
+primEnumSkip(void* methPtr, void* iptr, unsigned int celt)
+{
+ return ((enumSkip_methPtrTy)methPtr)(iptr,celt);
+
+}
+
+typedef unsigned int (__stdcall * enumReset_methPtrTy)(void* iptr);
+
+HRESULT
+primEnumReset(void* methPtr, void* iptr)
+{
+ return ((enumReset_methPtrTy)methPtr)(iptr);
+}
+
+typedef unsigned int (__stdcall * enumClone_methPtrTy)(void* iptr,void* ppv);
+
+HRESULT
+primEnumClone(void* methPtr, void* iptr, void* ppv)
+{
+ return ((enumClone_methPtrTy)methPtr)(iptr,ppv);
+
+}
+
+typedef unsigned int (__stdcall * persistLoad_methPtrTy)(void* iptr,void* pszFileName,unsigned int dwMode);
+
+HRESULT
+primPersistLoad(void* methPtr, void* iptr, void* pszFileName, unsigned int dwMode)
+{
+ return ((persistLoad_methPtrTy)methPtr)(iptr,pszFileName,dwMode);
+}
+
+HRESULT primGetActiveObject( CLSID* clsid, IUnknown** unk )
+{
+  if (!unk) return E_POINTER;
+       else *unk = NULL;
+  return GetActiveObject( clsid, NULL, unk );
+}
+
+HRESULT primLoadRegTypeLib 
+                        ( GUID* rguid
+			, short wMaj
+			, short wMin
+			, LCID lcid
+			, void** ppv
+			)
+{
+  HRESULT hr;
+
+  hr = LoadRegTypeLib(rguid, wMaj, wMin, GetUserDefaultLCID(), (IUnknown**)ppv);
+  return hr;  
+}
+
+
+void messageBox (char* str, char* t, unsigned long x)
+{
+ MessageBox ( NULL, str, t, x);
+ return;
+}
+
+IID* primNullIID () { return (IID*)(&IID_NULL); }
+
+DWORD
+lOCALE_USER_DEFAULT()
+{ 
+ return(GetUserDefaultLCID());
+}
+
+BOOL  primComEqual( IUnknown* unk1, IUnknown* unk2 )
+{
+   IUnknown* obj1;
+   IUnknown* obj2;
+   BOOL    res;
+   HRESULT hr;
+
+   if (!unk1)  return (unk2 == NULL);
+   if (!unk2)  return FALSE;
+
+   hr = IUnknown_QueryInterface( unk1, &IID_IUnknown, (void**)&obj1 );
+   if (FAILED(hr)) return FALSE;
+   hr = IUnknown_QueryInterface( unk2, &IID_IUnknown, (void**)&obj2 );
+   if (FAILED(hr)) {IUnknown_Release(obj1); return FALSE; }
+
+   res = (obj1 == obj2);
+   IUnknown_Release(obj1);
+   IUnknown_Release(obj2);
+   return res;
+}
+
+HRESULT
+primCopyGUID (GUID* g1, GUID* g2)
+{
+  if (g2 == NULL || g1 == NULL) {
+    return E_FAIL;
+  } else {
+    memcpy(g2,g1,sizeof(GUID));
+    return S_OK;
+  }
+}
+
+HRESULT
+primNewGUID (GUID* g1)
+{
+  if (g1 == NULL) {
+    return E_FAIL;
+  } else {
+    return CoCreateGuid(g1);
+  }
+}
+
+
+/*
+ *
+ * CreateTypeLib() stub.
+ *
+ */
+HRESULT primCreateTypeLib ( int i, LPOLESTR fname, void** ppv )
+{
+  /* Not much point really of defining this stub, since
+   * should really be using the FFI, but a little bit
+   * easier to debug this way until we know everything's reaonable
+   * stable.
+   */
+
+  /* Unfortunately, the cygwin/mingw liboleaut32.a import library doesn't have an entry
+   * for _CreateTypeLib@12, so you either have to generate your own version of it (which
+   * I did), or fall back on CreateTypeLib().
+   */
+#ifdef _MSC
+  return ( CreateTypeLib2(1/*SYS_WIN32*/, fname, ppv) );
+#else
+  return ( CreateTypeLib(1/*SYS_WIN32*/, fname, ppv) );
+#endif
+}
+
+BSTR primQueryPathOfRegTypeLib ( GUID* rguid
+			       , unsigned short maj
+			       , unsigned short min
+			       )
+{
+  BSTR bs;
+  HRESULT hr;
+  bs = SysAllocStringByteLen (NULL, 255);
+  
+  hr = QueryPathOfRegTypeLib ( rguid, maj, min, GetUserDefaultLCID(), &bs);
+  
+  if (FAILED(hr)) {
+     SysFreeString(bs);
+     return NULL;
+  }
+  return bs;
+}
+
+#define MAX_LEN_MOD_FNAME 2048
+
+char*
+getModuleFileName ( HANDLE hMod)
+{
+  char* buf = malloc(sizeof(char) * MAX_LEN_MOD_FNAME);
+  DWORD len;
+
+  len = GetModuleFileNameA(hMod, buf, MAX_LEN_MOD_FNAME);
+  return buf;
+
+}
+
+/*-----------------------------------------------------------
+-- Message pumping utils
+-----------------------------------------------------------*/
+void messagePump()
+{
+  MSG msg;
+
+  while ( GetMessage(&msg, 0, 0, 0) ) {
+    DispatchMessage(&msg);
+  }
+}
+
+HANDLE
+mkEvent()
+{
+  return CreateEvent(NULL, FALSE, FALSE, NULL);
+}
+
+void
+waitForEvent (HANDLE h)
+{
+  HANDLE ha = h;
+  DWORD dwR;
+  MSG msg;
+
+  while(1) {
+    dwR = MsgWaitForMultipleObjects(1, &ha, FALSE, INFINITE, QS_ALLEVENTS);
+    if (dwR == WAIT_OBJECT_0) {
+       break;
+    } else {
+      while (PeekMessage(&msg,NULL, 0, 0, PM_REMOVE)) {
+	TranslateMessage(&msg);
+	DispatchMessage(&msg);
+      }
+    }
+  }
+    
+}
+
+void
+signalEvent(HANDLE h)
+{
+  SetEvent(h);
+}
+
+/* Add a WM_QUIT to the STA thread's message queue, causing the
+   above pump to shutdown.
+ */
+void postQuitMsg()
+{
+ PostMessage(NULL, WM_QUIT, 0, 0); 
+}
+
+/*-----------------------------------------------------------
+-- BSTR  <--> String operations:
+-----------------------------------------------------------*/
+
+HRESULT
+stringToBSTR( /*[in,ptr]*/const char* pstrz
+	    , /*[out]*/ BSTR* pbstr
+	    )
+{
+  int i;
+
+  if (!pbstr) {
+    return E_FAIL;
+  } else {
+    *pbstr = NULL;
+  }
+  if (!pstrz) {
+    return S_OK;
+  }
+
+  i = MultiByteToWideChar(CP_ACP, 0, pstrz, -1, NULL, 0);
+  if ( i < 0 ) {
+    return E_FAIL;
+  }
+
+  /* i is the length of the string *including* the null-terminator
+   * (which we don't want in the BSTR).  So the length of the BSTR is
+   * i-1.
+   */
+  *pbstr = SysAllocStringLen(NULL,i-1);
+  if (*pbstr != NULL) {
+    MultiByteToWideChar(CP_ACP, 0, pstrz, -1, *pbstr, i-1); 
+    return S_OK;
+  } else {
+    return E_FAIL;
+  }
+}
+
+int
+bstrLen( /*[in]*/ BSTR bstr )
+{
+   if (!bstr) {
+      return 0;
+   }
+   //   return wcstombs( NULL, bstr, SysStringLen(bstr)+1);
+   return WideCharToMultiByte ( CP_ACP, 0, bstr, SysStringLen(bstr)
+   			      , NULL, 0, NULL, NULL);
+}
+
+HRESULT
+bstrToStringLen ( BSTR bstr
+                , int len
+	        , char* p
+	        )
+{
+  int i;
+  if (!p) {
+     return E_FAIL;
+  } else {
+     *p = '\0';
+  }
+  if (!bstr) {
+     return E_FAIL;
+  }
+  //  i = wcstombs(p,bstr,len+1);
+  i = WideCharToMultiByte ( CP_ACP, 0, bstr, SysStringLen(bstr)
+		          , p, len, NULL, NULL);
+  if ( i == 0 ) {
+     return E_FAIL;
+  } else {
+     p[i]= '\0';
+     return S_OK;
+  }
+}
+
+/*
+ * Wrapper for the interesting bits of GetVersionEx()
+ */
+void
+primGetVersionInfo
+    ( /*[out]*/unsigned long* maj
+    , /*[out]*/unsigned long* min
+    , /*[out]*/unsigned long* pid
+    )
+{
+  OSVERSIONINFO oe;
+  BOOL b;
+  
+  oe.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
+  
+  b = GetVersionEx(&oe);
+  
+#ifdef DEBUG
+  if (!b) {
+    fprintf(stderr, "GetVersionEx failed\n");
+    exit(1);
+  }
+#endif
+  /* Assume everything went well */
+  *maj = oe.dwMajorVersion;
+  *min = oe.dwMinorVersion;
+  *pid = oe.dwPlatformId;
+
+  return;
+}
+
+/*
+ * IUnknown finaliser called by GC when ForeignObjs holding them 
+ * are finalised.
+ */
+
+void
+releaseIUnknown__(void* ip)
+{
+  DWORD d;
+#ifdef DEBUG
+  fprintf(stderr, "Releasing COM i-pointer 0x%p\n", ip); fflush(stderr);
+#endif
+  if (ip) {
+    d = IUnknown_Release((IUnknown*)ip);
+#ifdef DEBUG
+    fprintf(stderr, "Released COM i-pointer 0x%p %d\n", ip, d); fflush(stderr);
+#endif
+  }
+}
+
+void*
+addrOfReleaseIUnknown()
+{
+  /* Strictly speaking, converting a function pointer to a void*
+     is not guaranteed to be information preserving in ANSI C.
+  */
+  return (void*)&releaseIUnknown__;
+}
+ cbits/PointerSrc.c view
@@ -0,0 +1,149 @@+/* This stuff will eventually be replaced by calls to the
+   storage manager in the new GHC/Hugs RTS.   -- sof
+*/
+
+#if defined(__CYGWIN32__) || defined(__MINGW32__) || defined(__CYGWIN__)
+#define __BASTARDIZED_WIN32__ 1
+#endif
+
+/*-----------------------------------------------------------
+-- (c) 1998,  Daan Leijen, leijen@@fwi.uva.nl
+-----------------------------------------------------------*/
+/* #define DEBUG */
+
+/* if you don't use COM, comment this out */
+/* (pass the setting for this via command line instead.) */
+/* #define COM */
+
+/* define the DLL export macro */
+#if defined(_BASTARDIZED_WIN32__)
+#define DLLEXPORT(res)  __declspec(dllexport) res
+#else
+/* redef this default for your system */
+#define DLLEXPORT(res)  extern res
+#endif
+
+
+#ifdef COM
+#define COBJMACROS
+#define CINTERFACE
+#endif
+
+#include <stdio.h>
+
+#if !defined(__BASTARDIZED_WIN32__) && defined(COM)
+#include <windows.h>
+#else
+# if defined(__BASTARDIZED_WIN32__)
+  #include <windows.h>
+# if defined(__BASTARDIZED_WIN32__) && defined(COM)
+  #include "comPrim.h"
+# endif
+# endif
+#include <stdlib.h>
+#endif
+
+#ifdef DEBUG
+static int nallocs = 0;
+static int nallocs_ = 0;
+#endif
+
+void primPointerCheck(void)
+{
+#ifdef DEBUG
+    if (nallocs - nallocs_ != 0)
+      printf( "pointer errors: allocs - frees = %i\n", nallocs - nallocs_ );
+    nallocs_ = nallocs;
+#endif    
+}     
+
+/*-----------------------------------------------------------
+-- Free routines for foreign objects
+-----------------------------------------------------------*/
+
+DLLEXPORT(void) primFreeBSTR( void* p )
+{
+#ifdef COM
+   if (p) SysFreeString( (BSTR)p );
+#endif
+}
+
+DLLEXPORT(void) primNoFree( void* p )
+{
+#if 0
+ char    msg[200];
+ WCHAR* wmsg;
+ HRESULT hr;
+
+ sprintf(msg, "freeing: %p", p);
+ MessageBox(NULL, msg, "primNoFree", MB_OK );
+
+ hr = primGUIDToString(p, &wmsg);
+ if (SUCCEEDED(hr)) {
+    MessageBoxW(NULL, wmsg, L"primNoFree-clsid", MB_OK);
+ }
+#endif
+}
+
+void primFinalise (void* f, void* a)
+{ ((void (*)(void *))f)(a); } 
+
+
+/*-----------------------------------------------------------
+-- Memory allocation
+-----------------------------------------------------------*/
+
+DLLEXPORT(void*) primAllocMemory( int size )
+{
+#ifdef COM
+
+#ifdef DEBUG
+    void* p;
+    p = CoTaskMemAlloc( size );
+    printf("alloc: %p, size = %i\n", p, size );
+    if (p) nallocs++;
+    return p;
+#else
+    return CoTaskMemAlloc(size);
+#endif
+
+#else
+    return malloc(size);
+#endif
+}
+
+/* COM version of freeing */
+#ifdef COM
+DLLEXPORT(void) primFreeMemory( void* p )
+{
+ #ifdef DEBUG    
+   if (!p) printf( "freeing null pointer\n" );
+ #endif
+   if (!p) return;
+ #ifdef DEBUG
+   if (p) nallocs--;
+   printf( "free: %p\n", p);
+ #endif
+   CoTaskMemFree( p );
+}
+#endif
+
+#ifndef COM
+DLLEXPORT(void) primFreeMemory( void* p )
+{
+ #ifdef DEBUG    
+   if (!p) printf( "free null pointer\n" );
+ #endif
+
+   if (!p) return;
+
+   free(p);
+}
+#endif /* !COM */
+
+/* Strictly speaking, converting a function pointer to a void*
+   is not guaranteed to be information preserving in ANSI C.
+*/
+void* finalFreeMemory() { return (void*)&primFreeMemory; }
+void* finalNoFree()     { return (void*)&primNoFree;   }
+void* finalFreeBSTR()   { return (void*)&primFreeBSTR; }
+ cbits/Registry.c view
@@ -0,0 +1,254 @@+/*
+  Misc helper functions for accessing the registry.
+*/
+#include <windows.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include "comPrim.h"
+
+#if __CYGWIN32__
+int wcslen(WCHAR* wstr)
+{
+  return WideCharToMultiByte(CP_ACP, WC_DEFAULTCHAR, wstr, (-1), NULL, 0, NULL, NULL);
+}
+#endif
+
+/* 
+ RegAddEntry() adds a key + string value at
+
+      HKEY_CLASSES_ROOT\path\subKey1\subKey2
+
+*/
+HRESULT
+RegAddEntry(int hive,
+	    const char* path,
+            const char* subKey1,
+            const char* subKey2,
+            const char* value)
+{
+   HKEY hKey;
+   char keyBuffer[1024]; /* Sigh! */
+   long result;
+   HANDLE the_hive;
+
+   switch(hive) {
+    case 0: the_hive = HKEY_CLASSES_ROOT; break;
+    case 1: the_hive = HKEY_CURRENT_USER; break;
+    case 2: the_hive = HKEY_LOCAL_MACHINE; break;
+    case 3: the_hive = HKEY_USERS; break;
+    case 4: the_hive = HKEY_CURRENT_CONFIG; break;
+   default:
+     MessageBox (NULL, "RegAddEntry: weird hive", "RegAddEntry", MB_OK | MB_ICONINFORMATION );
+     return E_FAIL;
+   }
+
+   /* construct complete path in buffer. */
+   strcpy(keyBuffer, path) ;
+   if (subKey1 != NULL) {
+	strcat(keyBuffer, "\\") ;
+	strcat(keyBuffer, subKey1 ) ;
+   }
+
+   if (subKey2 != NULL) {
+	strcat(keyBuffer, "\\") ;
+	strcat(keyBuffer, subKey2 ) ;
+   }
+
+   /* Create and open key and subkey. */
+   result = RegCreateKeyEx(the_hive,
+	                   keyBuffer, 
+	                   0, NULL, REG_OPTION_NON_VOLATILE,
+	                   KEY_ALL_ACCESS, NULL, 
+	                   &hKey, NULL) ;
+   if (result != ERROR_SUCCESS) {
+	return S_FALSE;
+   }
+
+   /* Set the value */
+   if (value != NULL) {
+      RegSetValueEx(hKey, NULL, 0, REG_SZ, 
+	            (BYTE *)value, 
+	            strlen(value)+1) ;
+   }
+
+   RegCloseKey(hKey) ;
+   return S_OK;
+}
+
+/* Called by Haskell code */
+HRESULT
+primRegAddEntry ( int hive, const char* path, const char* val)
+{
+ return RegAddEntry( hive, path, NULL, NULL, val);
+}
+
+#define REMOVE_KEY    1
+#define REMOVE_VALUE  0
+
+/*
+ RegRemoveEntry() adds a key + string value at
+
+      HKEY_CLASSES_ROOT\path\subKey1\subKey2
+*/
+HRESULT
+RegRemoveEntry
+         ( int hive
+	 , const char* path
+         , const char* subKey1
+	 , const char* subKey2
+	 , int deleteKey
+	 )
+{
+   HKEY hKey;
+   LONG res;
+   char keyBuffer[1024]; /* Sigh! */
+   HANDLE the_hive;
+
+   switch(hive) {
+    case 0: the_hive = HKEY_CLASSES_ROOT; break;
+    case 1: the_hive = HKEY_CURRENT_USER; break;
+    case 2: the_hive = HKEY_LOCAL_MACHINE; break;
+    case 3: the_hive = HKEY_USERS; break;
+    case 4: the_hive = HKEY_CURRENT_CONFIG; break;
+   default:
+     MessageBox (NULL, "RegAddEntry: weird hive", "RegAddEntry", MB_OK | MB_ICONINFORMATION );
+     return E_FAIL;
+   }
+
+   /* construct complete path in buffer. */
+   strcpy(keyBuffer, path);
+
+   if (subKey1 != NULL) {
+	strcat(keyBuffer, "\\") ;
+	strcat(keyBuffer, subKey1 ) ;
+   }
+
+   res = RegOpenKeyEx 
+             ( the_hive
+	     , keyBuffer
+	     , 0
+	     , KEY_SET_VALUE
+	     , &hKey
+	     );
+   if ( res != ERROR_SUCCESS ) {
+     MessageBox (NULL, "RegOpenKeyEx() failed", "RegRemoveEntry", MB_OK | MB_ICONINFORMATION );
+     return S_FALSE;
+   }
+   if ( deleteKey ) {
+     res = RegDeleteKey (hKey, subKey2 );
+   } else {
+     res = RegDeleteValue (hKey, subKey2 );
+   }
+   RegCloseKey(hKey) ;
+   return ( res == ERROR_SUCCESS ? S_OK : S_FALSE );
+}
+
+/* Called by Haskell code */
+HRESULT
+primRegRemoveEntry ( int hive, const char* path, const char* val, int kind)
+{
+ return RegRemoveEntry( hive, path, NULL, val, kind);
+}
+
+#if 0
+HRESULT
+RegisterServer ( HMODULE  hMod
+	       , REFCLSID rclsid
+	       , const char* name
+	       , const char* verProgID
+	       , const char* progID
+	       )
+{
+   char    modBuffer[1024]; /* Sigh! */
+   WCHAR   wstr[45];
+   char*   clsid_str;
+   DWORD   st;
+   int     i;
+   HRESULT hr;
+
+   st = GetModuleFileName (hMod, modBuffer, 1024);
+
+   if ( st == 0 ) {
+     MessageBox (NULL, "GetModuleFileName() failed", "Msg", MB_OK | MB_ICONINFORMATION );
+     return S_FALSE;
+   }
+
+   i = StringFromGUID2 ( rclsid, wstr, 45);
+   if (i == 0) {
+     MessageBox (NULL, "StringFromGUID2() failed", "RegisterServer", MB_OK | MB_ICONINFORMATION );
+     return S_FALSE;
+   }
+   clsid_str = (char*)malloc((wcslen(wstr)+1)*sizeof(char));
+   UNI2STR(clsid_str,wstr);
+
+   /* 
+      HKCR\CLSID\{clsid}\{name}
+      HKCR\CLSID\{clsid}\InProcServer32\{dll-name}
+      HKCR\CLSID\{clsid}\ProgId\{prog-id}
+      HKCR\CLSID\{clsid}\VersionIndependentProgId\{vprog-id}
+
+      HKCR\{prog-id}\CLSID\{clsid}
+      HKCR\{vprog-id}\CLSID\{clsid}
+
+   */
+   hr = RegAddEntry(0, "CLSID", clsid_str , "", name);
+   if (FAILED(hr)) return hr;
+   hr = RegAddEntry(0, "CLSID", clsid_str , "InprocServer32", modBuffer);
+   if (FAILED(hr)) return hr;
+   hr = RegAddEntry(0, "CLSID", clsid_str , "ProgID", progID);
+   if (FAILED(hr)) return hr;
+   hr = RegAddEntry(0, "CLSID", clsid_str , "VersionIndependentProgID", verProgID);
+   if (FAILED(hr)) return hr;
+   hr = RegAddEntry(0, progID, "CLSID", NULL, clsid_str);
+   if (FAILED(hr)) return hr;
+   hr = RegAddEntry(0, verProgID, "CLSID", NULL, clsid_str);
+   if (FAILED(hr)) return hr;
+
+   return S_OK;   
+}
+#endif
+
+#if 0
+HRESULT
+UnregisterServer 
+               ( HMODULE  hMod
+	       , REFCLSID rclsid
+	       , const char* name
+	       , const char* verProgID
+	       , const char* progID
+	       )
+{ 
+   char    modBuffer[1024]; /* Sigh! */
+   WCHAR   wstr[45];
+   char*   clsid_str;
+   DWORD   st;
+   int     i;
+   HRESULT hr;
+
+   st = GetModuleFileName (hMod, modBuffer, 1024);
+
+   if ( st == 0 ) {
+     MessageBox (NULL, "GetModuleFileName() failed", "Msg", MB_OK | MB_ICONINFORMATION );
+     return S_FALSE;
+   }
+
+   i = StringFromGUID2 ( rclsid, wstr, 45);
+   if (i == 0) {
+     MessageBox (NULL, "StringFromGUID2() failed", "RegisterServer", MB_OK | MB_ICONINFORMATION );
+     return S_FALSE;
+   }
+   clsid_str = (char*)malloc((wcslen(wstr)+1)*sizeof(char));
+   UNI2STR(clsid_str,wstr);
+
+   hr = RegRemoveEntry(0, "CLSID", clsid_str , "InprocServer32", REMOVE_KEY);
+   if (FAILED(hr)) return hr;
+   hr = RegRemoveEntry(0, "CLSID", clsid_str , "ProgID", REMOVE_KEY);
+   if (FAILED(hr)) return hr;
+   hr = RegRemoveEntry(0, "CLSID", clsid_str , "VersionIndependentProgID", REMOVE_KEY);
+   if (FAILED(hr)) return hr;
+   hr = RegRemoveEntry(0, "CLSID", NULL , clsid_str, REMOVE_KEY);
+   if (FAILED(hr)) return hr;
+   return S_OK;
+}
+#endif
+ cbits/SafeArrayPrim.c view
@@ -0,0 +1,10 @@+
+#include "autoPrim.h"
+#include "SafeArrayPrim.h"
+
+/* Finaliser for SAFEARRAYs */
+void
+primSafeArrayDestroy(void* p)
+{
+  SafeArrayDestroy((SAFEARRAY*)p);
+}
+ cbits/WideStringSrc.c view
@@ -0,0 +1,177 @@+/* define the DLL export macro */
+#if defined(_WIN32) && !defined(__CYGWIN32__)
+#define DLLEXPORT(res)  __declspec(dllexport) res
+#else
+/* redef this default for your system */
+#define DLLEXPORT(res)  extern res
+#endif
+
+
+#ifdef COM
+#define COBJMACROS
+#define CINTERFACE
+#endif
+
+#include <stdio.h>
+
+#if defined(_WIN32) && !defined(__CYGWIN32__)
+#include <windows.h>
+#define WCHAR wchar_t
+#else
+ #ifdef __CYGWIN32__
+  #include <windows.h>
+ #endif
+#include <stdlib.h>
+#define WCHAR wchar_t
+#endif
+
+#include "WideStringSrc.h"
+
+#ifdef COM
+#include "comPrim.h"
+#else
+#define UNI2STR(regstr, unistr) wcstombs (regstr, unistr, wcslen (unistr)+1)
+#endif
+
+/* wcslen() substitute implementation for cygwin'ers. */
+#if defined(__CYGWIN32__) || defined(__CYGWIN__)
+
+/* Troublesome to use the one that comes with 20.1 of cygwin */
+#ifdef MB_CUR_MAX
+#undef MB_CUR_MAX
+#endif
+#define MB_CUR_MAX 2
+
+static int wcslen(WCHAR* wstr)
+{
+  char str[MB_CUR_MAX];
+  char msg[80];
+  WCHAR* wptr;
+  int nbytes, i = 0;
+  
+  wptr = wstr;
+
+  if ( wptr == NULL )
+     return 0;
+
+  while ( *wptr != L'\0' ) {
+     nbytes = wctomb ( str, *wptr );
+     i += nbytes; (char*)wptr += nbytes;
+  }
+  return i;
+}
+#endif
+
+
+/* Return the length of a wide string big enough
+   to hold the multi-byte string.
+*/
+unsigned int wideStringLen (char* str)
+{
+#ifdef _WIN32
+  return MultiByteToWideChar(CP_ACP, 0, str, -1, NULL, 0);
+#else
+  /* Non Win32 specific version */
+  WCHAR foo[300];  // Ho-ho, bulletproof!
+  unsigned int len;
+
+  if (!str) {
+     return 0;
+  } else {
+     len = mbstowcs (foo, str, strlen(str));
+     return ( (len < 0) ? 0 : len);
+  }
+#endif
+}
+
+/* ToDo: sort out source code deps. and make
+   the return type HRESULT.
+*/
+int
+wideToString ( WCHAR* wstr, char** pstr )
+{
+  int len;
+  char* str;
+
+  if (!pstr) {
+#ifdef _WIN32
+    return E_FAIL;
+#else
+    return -1;
+#endif
+  }
+
+#if defined(_WIN32) && defined(COM)
+
+  /* Compute how big a buffer we need to allocate for
+     multi-byte string...
+  */
+  len = WideCharToMultiByte ( CP_ACP, 0, wstr, -1
+			    , NULL, 0, NULL, NULL);
+  if (len == 0) {
+    return E_FAIL;
+  }
+
+  /* 
+    Ask COM task allocator for some memory.
+   */
+  str = CoTaskMemAlloc(len * sizeof(char));
+  if (str == NULL) {
+    return E_FAIL;
+  }
+
+  WideCharToMultiByte(CP_ACP, 0, wstr, -1, str, len, NULL, NULL);
+  *pstr = str;
+  return S_OK;
+
+#else
+
+  len = wcslen(wstr);
+  str=(char*)malloc(len+1);
+  UNI2STR(str,wstr);
+  *pstr = str;
+  return 0;
+
+#endif
+}
+
+/* Converting (null-terminated) strings into wide/Unicode ones */
+int primStringToWide( char* str, unsigned int len, WCHAR* wstr , unsigned int wlen )
+{
+#ifdef _WIN32
+  return MultiByteToWideChar(CP_ACP, 0, str, len, wstr, wlen);
+#else
+  int l;
+
+  if ( wstr ) {
+    if ( !str ) {
+       *wstr = 0;
+       return 0;
+    } else {
+       l = mbstowcs (wstr, str, wlen+1);
+       return l;
+    }
+ } else {
+    return (-1);
+ }
+#endif
+}
+
+/* The proto might not be in scope, so you might
+   just get a warning from the C compiler.
+   
+   Reluctant to define the proto, as experience has
+   shown this to be troublesome (there appears to be no
+   universal agreement as to what the return type of
+   wcslen() is.)
+
+extern int wcslen (const WCHAR* wstr);
+extern size_t wcslen (const WCHAR* wstr);
+
+*/  
+
+int
+lenWideString (WCHAR* wstr )
+{
+  return wcslen(wstr);
+}
+ com.cabal view
@@ -0,0 +1,73 @@+Name: com
+version: 1.1
+Synopsis: Haskell COM support library
+Description: 
+    COM + Automation libraries for Haskell.
+Cabal-version: >= 1.2
+build-type: Simple
+Maintainer: Sigbjorn Finne <sigbjorn.finne@gmail.com>
+License: BSD3
+License-file: LICENSE
+Category: FFI
+
+Extra-Source-Files: include/PointerSrc.h
+          include/WideStringSrc.h
+          include/HDirect.h
+          include/comPrim.h
+          include/autoPrim.h
+          include/Registry.h
+          include/safeArrayPrim.h
+          include/SafeArray.h
+          include/StdTypes.h
+
+library {
+Build-depends: base, haskell98, old-time
+Exposed-Modules: System.Win32.Com,
+                 System.Win32.Com.Base,
+                 System.Win32.Com.Automation,
+                 System.Win32.Com.Automation.Base,
+                 System.Win32.Com.Automation.StdTypes,
+                 System.Win32.Com.Automation.SafeArray,
+                 System.Win32.Com.Exception,
+                 System.Win32.Com.Automation.TypeLib,
+                 System.Win32.Com.Automation.Connection,
+                 System.Win32.Com.Dll,
+                 System.Win32.Com.Server,
+                 System.Win32.Com.ClassFactory,
+                 System.Win32.Com.Server.StdDispatch,
+                 System.Win32.Com.Server.ConnectionPoint,
+                 System.Win32.Com.Server.ClassInfo,
+                 System.Win32.Com.Server.EnumInterface,
+                 System.Win32.Com.Server.ExeServer,
+                 System.Win32.Com.HDirect.Pointer,
+                 System.Win32.Com.HDirect.HDirect,
+                 System.Win32.Com.HDirect.PointerPrim,
+                 System.Win32.Com.HDirect.WideString
+                 
+Other-Modules:
+Include-dirs: . cbits include
+
+Includes: include/PointerSrc.h
+          include/WideStringSrc.h
+          include/comPrim.h
+          include/autoPrim.h
+          include/Registry.h
+          include/safeArrayPrim.h
+          include/SafeArray.h
+          include/StdTypes.h
+
+C-Sources: cbits/PointerSrc.c
+           cbits/WideStringSrc.c
+           cbits/ComPrimSrc.c
+           cbits/AutoPrimSrc.c
+           cbits/Registry.c
+           cbits/SafeArrayPrim.c
+
+Extra-libraries: kernel32, user32, ole32, oleaut32, advapi32
+GHC-Options: -fglasgow-exts -fvia-C 
+-- I can't seem to feed this into the 'ld' invocation that creates the
+-- relocatable object file.
+Ld-options: --enable-stdcall-fixup --disable-stdcall-fixup
+Extensions: CPP
+CPP-Options: -DFOR_GHC=1
+}
+ include/HDirect.h view
@@ -0,0 +1,215 @@+/* --------------------------------------------------------------------------+ * GreenCard / HaskellDirect include file.+ *+ * Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale+ * Haskell Group 1994-99, and is distributed as Open Source software+ * under the Artistic License; see the file "Artistic" that is included+ * in the distribution for details.+ *+ * sof 4/99 - changed to make it useable with HaskellDirect.+ * + * $RCSfile: HDirect.h,v $+ * $Revision: 1.1 $+ * $Date: 2007-08-16 22:01:07 $+ * ------------------------------------------------------------------------*/++/* --------------------------------------------------------------------------+ *+ *                                  WARNING+ *+ * Most of the code in this file must exactly match corresponding definitions+ * in the Hugs source code.+ *+ * We have chosen to copy this code over to avoid the need to #include huge+ * chunks of the Hugs internal definitions (which sometimes conflict with+ * Xlib, Win32 or other libraries which we might also have to #include).+ *+ *+ * sof 4/99 - removed #include of config.h and options.h, since its only use+ *            appeared to be to pick up whether the host C compiler supported+ *            prototypes or not. Most do nowadays.+ * ------------------------------------------------------------------------*/++#ifndef __HDIRECT_H__+#define __HDIRECT_H__++#if 1 /* PROTOTYPES */   /* To enable use of prototypes whenever possible */+#define Args(x) x+#else+#define Args(x) ()+#endif++typedef unsigned char      hugs_uint8_t;+typedef unsigned short     hugs_uint16_t;+typedef unsigned int       hugs_uint32_t;+typedef signed   char      hugs_int8_t;+typedef signed   short     hugs_int16_t;+typedef signed   int       hugs_int32_t;+# ifdef _MSC_VER+typedef unsigned __int64   hugs_uint64_t;+typedef          __int64   hugs_int64_t;+# else+typedef unsigned long long hugs_uint64_t;+typedef signed   long long hugs_int64_t;+# endif++typedef int            HsInt;        +typedef hugs_int8_t    HsInt8;         +typedef hugs_int16_t   HsInt16;        +typedef hugs_int32_t   HsInt32;        +typedef unsigned int   HsWord;       +typedef hugs_uint8_t   HsWord8;        +typedef hugs_uint16_t  HsWord16;       +typedef hugs_uint32_t  HsWord32;       ++/* + * Here we deviate from the FFI specification:+ * If we make them both float, then there's no way to pass a double+ * to C which means we can't call common C functions like sin.+ */           +typedef float          HsFloat;      +typedef double         HsDouble;     ++typedef hugs_int64_t   HsInt64;        +typedef hugs_uint64_t  HsWord64;       +typedef char           HsChar;+typedef int            HsBool;         +typedef void*          HsAddr;       +typedef void*          HsPtr;          +typedef void           (*HsFunPtr)(void);+typedef void*          HsForeignPtr;   +typedef void*          HsStablePtr;  ++typedef int   HugsStackPtr;+typedef int   HugsStablePtr;+typedef void* HugsForeign;+++#define primFun(name)	 static void name(HugsStackPtr hugs_root)+#define hugs_returnIO(n) hugs->returnIO(hugs_root,n)+#define hugs_returnId(n) hugs->returnId(hugs_root,n)++/* These declarations must exactly match those in storage.h */++typedef void (*Prim) Args((HugsStackPtr)); /* primitive function	   */++extern struct hugs_primitive {		/* table of primitives		   */+    char*  ref;				/* primitive reference string	   */+    int	   arity;			/* primitive function arity	   */+    Prim   imp;				/* primitive implementation	   */+} primitives[];++struct hugs_primInfo {+    void                   (*controlFun) Args((int));+    struct hugs_primitive  *primFuns;+    struct hugs_primInfo   *nextPrimInfo;+};++/* This is an exact copy of the declaration found in storage.h */++typedef struct {++  /* evaluate next argument */+  HsInt          (*getInt)         (void);+  HsWord         (*getWord)        (void);+  HsAddr    	 (*getAddr)        (void);+  HsFloat        (*getFloat)       (void);+  HsDouble       (*getDouble)      (void);+  HsChar         (*getChar)        (void);+  HugsForeign    (*getForeign)     (void);+  HugsStablePtr  (*getStablePtr)   (void); /* deprecated */++  /* push part of result   */+  void           (*putInt)         (HsInt);+  void      	 (*putWord)        (HsWord);+  void      	 (*putAddr)        (HsAddr);+  void           (*putFloat)       (HsFloat);+  void           (*putDouble)      (HsDouble);+  void           (*putChar)        (HsChar);+  void      	 (*putForeign)     (HugsForeign, void (*)(HugsForeign));+  void           (*putStablePtr)   (HugsStablePtr); /* deprecated */++  /* return n values in IO monad or Id monad */+  void      	 (*returnIO)       (HugsStackPtr, int);+  void      	 (*returnId)       (HugsStackPtr, int);+  int      	 (*runIO)          (int);++  /* free a stable pointer */	    			 +  void      	 (*freeStablePtr)  (HugsStablePtr); /* deprecated */++  /* register the prim table */	    			 +  void      	 (*registerPrims)  (struct hugs_primInfo*);+			   +  /* garbage collect */+  void		 (*garbageCollect) (void);++  /* API3 additions follow */+  HugsStablePtr  (*lookupName)     (char*, char*);+  void           (*ap)             (int);+  void           (*getUnit)        (void);+  void*          (*mkThunk)        (HsFunPtr, HugsStablePtr);+  void           (*freeThunk)      (void*);+  HsBool         (*getBool)        (void);+  void           (*putBool)        (HsBool);++  /* API4 additions follow */+  HsInt8         (*getInt8)        (void);+  HsInt16        (*getInt16)       (void);+  HsInt32        (*getInt32)       (void);+  HsInt64        (*getInt64)       (void);+  HsWord8        (*getWord8)       (void);+  HsWord16       (*getWord16)      (void);+  HsWord32       (*getWord32)      (void);+  HsWord64       (*getWord64)      (void);+  HsPtr          (*getPtr)         (void);+  HsFunPtr       (*getFunPtr)      (void);+  HsForeignPtr   (*getForeignPtr)  (void);++  void           (*putInt8)        (HsInt8);+  void           (*putInt16)       (HsInt16);+  void           (*putInt32)       (HsInt32);+  void           (*putInt64)       (HsInt64);+  void           (*putWord8)       (HsWord8);+  void           (*putWord16)      (HsWord16);+  void           (*putWord32)      (HsWord32);+  void           (*putWord64)      (HsWord64);+  void           (*putPtr)         (HsPtr);+  void           (*putFunPtr)      (HsFunPtr);+  void           (*putForeignPtr)  (HsForeignPtr);++  HugsStablePtr  (*makeStablePtr4) (void);+  void           (*derefStablePtr4)(HugsStablePtr);++  void           (*putStablePtr4)  (HsStablePtr);+  HsStablePtr    (*getStablePtr4)  (void);+  void      	 (*freeStablePtr4) (HsStablePtr);++  int      	 (*runId)          (int);+} HugsAPI4;++HugsAPI4 *hugs; /* pointer to virtual function table */++/* +  copyBytes() is needed when dealing with +  functions that return structs++  Note: we're (intentionally!) relying on memcpy() to handle+  malloc() failure for us.+*/+#define copyBytes(len,struct_ptr) \+    memcpy((char*)malloc(len*sizeof(char)),(char*)(struct_ptr), len)++/* Copied verbatim from prelude.h */++#ifdef _MSC_VER /* Microsoft Visual C++ */+#define DLLIMPORT(rty) __declspec(dllimport) rty+#define DLLEXPORT(rty) __declspec(dllexport) rty+#elif defined __BORLANDC__ +#define DLLIMPORT(rty) rty far _import+#define DLLEXPORT(rty) rty far _export+#else +#define DLLIMPORT(rty) rty+#define DLLEXPORT(rty) rty+#endif /* Don't need to declare DLL exports */++#endif /* __HDIRECT_H__ */
+ include/PointerSrc.h view
@@ -0,0 +1,27 @@+#ifndef __POINTERSRC_H__
+#define __POINTERSRC_H__
+
+#if defined(__CYGWIN32__) || defined(__MINGW32__) || defined(__CYGWIN__)
+#define __BASTARDIZED_WIN32__ 1
+#endif
+
+#if defined(__BASTARDIZED_WIN32__) || defined(__MSVC__)
+#define SUPPORT_COM 1
+#endif
+
+extern void   primPointerCheck();
+extern void   primFinalise(void* f, void* a);
+extern void*  primAllocMemory(int size);
+extern void   primFreeMemory(void* p);
+extern void*  finalFreeMemory();
+extern void*  finalFreeObject();
+
+/* Versions using COM allocator */
+#if defined(SUPPORT_COM)
+extern void*  primCoAllocMemory(int size);
+extern void   primCoFreeMemory(void* p);
+extern void   primCoFreeBSTR(void* p);
+extern void*  finalCoFreeBSTR();
+#endif
+
+#endif /* __POINTERSRC_H__ */
+ include/Registry.h view
@@ -0,0 +1,34 @@+#ifndef __REGISTRY_H__
+#define __REGISTRY_H__
+
+extern
+HRESULT
+primRegAddEntry ( int hive, const char* path, const char* val);
+
+extern
+HRESULT
+primRegRemoveEntry ( int hive, const char* path, const char* val, int kind);
+
+#if 0
+extern
+HRESULT
+RegisterServer ( HMODULE  hMod
+	       , REFCLSID rclsid
+	       , const char* name
+	       , const char* verProgID
+	       , const char* progID
+	       );
+extern
+HRESULT
+UnregisterServer 
+               ( HANDLE hMod
+	       , REFCLSID rclsid
+	       , const char* name
+	       , const char* verProgID
+	       , const char* progID
+	       );
+
+#endif
+
+
+#endif
+ include/SafeArray.h view
@@ -0,0 +1,73 @@+/*
+Automatically generated by HaskellDirect (ihc.exe), snapshot 260805
+Created: 17:44 Pacific Standard Time, Thursday 27 October, 2005
+Command line: -fno-qualified-names -fhs-to-c -fno-export-lists --gen-headers -fout-pointers-are-not-refs --gen-headers -c SafeArray.idl
+*/
+
+
+#ifndef __INT64_DEFINED__
+#ifdef __GNUC__
+typedef long long int64;
+typedef unsigned long long uint64;
+#else
+#ifdef _MSC_VER
+typedef __int64 int64;
+typedef unsigned __int64 uint64;
+#else
+/* Need some help here, please. */
+#endif
+#endif
+#define __INT64_DEFINED__
+#endif
+
+
+#ifndef __SAFEARRAY_H__
+#define __SAFEARRAY_H__
+#if defined(__MINGW32__) || defined(__CYGWIN32__)
+#include <w32api.h>
+#endif
+#if !defined(_MSC_VER) && __W32API_MAJOR_VERSION == 1
+typedef struct SAFEARRAY *SAFEARRAY;
+typedef struct tagSAFEARRAYBOUND {
+           unsigned long cElements;
+           long lLbound;
+        } SAFEARRAYBOUND;
+extern HRESULT __stdcall SafeArrayAccessData ( /*[in, ptr]*/SAFEARRAY* psa
+                                             , /*[out, ref]*/void** ppvData );
+extern HRESULT __stdcall SafeArrayAllocData ( /*[in, ptr]*/SAFEARRAY* psa );
+extern HRESULT __stdcall SafeArrayAllocDescriptor ( /*[in]*/unsigned long cDims
+                                                  , /*[out]*/SAFEARRAY** ppsaOut );
+extern HRESULT __stdcall SafeArrayCopy ( /*[in, ptr]*/SAFEARRAY* psa
+                                       , /*[out]*/SAFEARRAY** ppsaOut );
+/*[ref, finaliser("primSafeArrayDestroy"), finaliser("primSafeArrayDestroy"), ref, ref]*/
+extern SAFEARRAY* __stdcall SafeArrayCreate ( /*[in]*/unsigned short vt
+                                            , /*[in]*/unsigned long cDims
+                                            , /*[in, size_is(cDims)]*/SAFEARRAYBOUND* rgsabound );
+extern HRESULT __stdcall SafeArrayDestroy ( /*[in, ptr]*/SAFEARRAY* psa );
+extern HRESULT __stdcall SafeArrayDestroyData ( /*[in, ptr]*/SAFEARRAY* psa );
+extern HRESULT __stdcall SafeArrayDestroyDescriptor ( /*[in, ptr]*/SAFEARRAY* psa );
+extern unsigned long __stdcall SafeArrayGetDim ( /*[in, ptr]*/SAFEARRAY* psa );
+extern HRESULT __stdcall SafeArrayGetElement ( /*[in, ptr]*/SAFEARRAY* psa
+                                             , /*[in, ptr]*/long* rgIndices
+                                             , /*[in, ptr]*/void* pv );
+extern unsigned long __stdcall SafeArrayGetElemsize ( /*[in, ptr]*/SAFEARRAY* psa );
+extern HRESULT __stdcall SafeArrayGetLBound ( /*[in, ptr]*/SAFEARRAY* psa
+                                            , /*[in]*/unsigned long nDim
+                                            , /*[out]*/long* plLbound );
+extern HRESULT __stdcall SafeArrayGetUBound ( /*[in, ptr]*/SAFEARRAY* psa
+                                            , /*[in]*/unsigned long nDim
+                                            , /*[out]*/long* plLbound );
+extern HRESULT __stdcall SafeArrayLock ( /*[in, ptr]*/SAFEARRAY* psa );
+extern HRESULT __stdcall SafeArrayPtrOfIndex ( /*[in, ptr]*/SAFEARRAY* psa
+                                             , /*[in, ptr]*/long* rgIndices
+                                             , /*[out]*/void** ppvData );
+extern HRESULT __stdcall SafeArrayPutElement ( /*[in, ptr]*/SAFEARRAY* psa
+                                             , /*[in, ptr]*/long* rgIndices
+                                             , /*[in, ptr]*/void* pv );
+extern HRESULT __stdcall SafeArrayRedim ( /*[in, ptr]*/SAFEARRAY* psa
+                                        , /*[in, ref]*/SAFEARRAYBOUND* psaboundNew );
+extern HRESULT __stdcall SafeArrayUnaccessData ( /*[in, ptr]*/SAFEARRAY* psa );
+extern HRESULT __stdcall SafeArrayUnlock ( /*[in, ptr]*/SAFEARRAY* psa );
+#endif
+
+#endif
+ include/StdTypes.h view
@@ -0,0 +1,130 @@+/*
+Automatically generated by HaskellDirect (ihc.exe), snapshot 260805
+Created: 17:44 Pacific Standard Time, Thursday 27 October, 2005
+Command line: -fno-qualified-names -fno-export-list -fno-gen-variant-instances -fout-pointers-are-not-refs --gen-headers -c StdTypes.idl
+*/
+
+
+#ifndef __INT64_DEFINED__
+#ifdef __GNUC__
+typedef long long int64;
+typedef unsigned long long uint64;
+#else
+#ifdef _MSC_VER
+typedef __int64 int64;
+typedef unsigned __int64 uint64;
+#else
+/* Need some help here, please. */
+#endif
+#endif
+#define __INT64_DEFINED__
+#endif
+
+
+#ifndef __STDTYPES_H__
+#define __STDTYPES_H__
+#ifdef __MINGW32__
+#define __need_wchar_t
+#include <stddef.h>
+#endif
+#if 0
+typedef unsigned long UINT;
+typedef int INT;
+typedef long BOOL;
+typedef char BYTE;
+typedef long LONG;
+typedef unsigned long ULONG;
+typedef unsigned short WORD;
+typedef unsigned long DWORD;
+typedef unsigned short VARTYPE;
+typedef unsigned short USHORT;
+typedef DWORD LCID;
+typedef LONG SCODE;
+typedef short SHORT;
+typedef wchar_t WCHAR;
+typedef WCHAR TCHAR;
+typedef WCHAR OLECHAR;
+typedef /*[string]*/ WCHAR* LPOLESTR;
+typedef /*[string]*/ WCHAR* LPCOLESTR;
+typedef void* PVOID;
+typedef void* LPVOID;
+typedef float FLOAT;
+/*typedef [ignore] [ignore]struct _GUID {
+                      [ignore]unsigned long Data1;
+                      [ignore]unsigned short Data2;
+                      [ignore]unsigned short Data3;
+                      char [ignore] Data4[8];
+                   } GUID;*/
+typedef struct _GUID {
+DWORD Data1;
+WORD  Data2;
+WORD  Data3;
+BYTE  Data4[8];
+} GUID;
+/*typedef [ignore] GUID IID;*/
+typedef GUID IID;
+typedef IID* LPIID;
+/*typedef [ignore] GUID CLSID;*/
+typedef GUID CLSID;
+typedef CLSID* LPCLSID;
+typedef GUID FMTID;
+typedef FMTID* LPFMTID;
+typedef /*[ptr]*/ void* HWND;
+typedef /*[ptr]*/ void* HMENU;
+typedef /*[ptr]*/ void* HANDLE;
+typedef /*[ref]*/ GUID* REFGUID;
+typedef /*[ref]*/ IID* REFIID;
+typedef /*[ref]*/ CLSID* REFCLSID;
+typedef /*[ref]*/ FMTID* REFFMTID;
+typedef enum VARENUM {
+           VT_EMPTY = 0,
+           VT_NULL = 1,
+           VT_I2 = 2,
+           VT_I4 = 3,
+           VT_R4 = 4,
+           VT_R8 = 5,
+           VT_CY = 6,
+           VT_DATE = 7,
+           VT_BSTR = 8,
+           VT_DISPATCH = 9,
+           VT_ERROR = 10,
+           VT_BOOL = 11,
+           VT_VARIANT = 12,
+           VT_UNKNOWN = 13,
+           VT_DECIMAL = 14,
+           VT_I1 = 16,
+           VT_UI1 = 17,
+           VT_UI2 = 18,
+           VT_UI4 = 19,
+           VT_I8 = 20,
+           VT_UI8 = 21,
+           VT_INT = 22,
+           VT_UINT = 23,
+           VT_VOID = 24,
+           VT_HRESULT = 25,
+           VT_PTR = 26,
+           VT_SAFEARRAY = 27,
+           VT_CARRAY = 28,
+           VT_USERDEFINED = 29,
+           VT_LPSTR = 30,
+           VT_LPWSTR = 31,
+           VT_FILETIME = 64,
+           VT_BLOB = 65,
+           VT_STREAM = 66,
+           VT_STORAGE = 67,
+           VT_STREAMED_OBJECT = 68,
+           VT_STORED_OBJECT = 69,
+           VT_BLOB_OBJECT = 70,
+           VT_CF = 71,
+           VT_CLSID = 72,
+           VT_BSTR_BLOB = 4095,
+           VT_ILLEGALMASKED = 4095,
+           VT_TYPEMASK = 4095,
+           VT_VECTOR = 4096,
+           VT_ARRAY = 8192,
+           VT_BYREF = 16384,
+           VT_RESERVED = 32768,
+           VT_ILLEGAL = 65535
+        } VARENUM;
+#endif
+#endif
+ include/WideStringSrc.h view
@@ -0,0 +1,26 @@+
+#ifndef __WIDESTRING_H__
+#define __WIDESTRING_H__
+
+#ifndef WCHAR
+#define WCHAR wchar_t
+#endif
+
+extern
+int
+primStringToWide ( char* str
+                 , unsigned int len
+		 , WCHAR* wstr
+		 , unsigned int wlen
+		 );
+extern
+int
+wideToString ( WCHAR* wstr, char** pstr );
+
+extern
+unsigned int wideStringLen (char* str);
+
+extern
+int lenWideString (WCHAR* str);
+
+#endif
+ include/autoPrim.h view
@@ -0,0 +1,325 @@+/*
+ To free ourselves from a couple of needless compiler/
+ header file dependencies, we provide a hand-written
+ set of definitions for Automation related types
+ and interfaces.
+*/
+#ifndef __AUTOPRIM_H__
+#define __AUTOPRIM_H__
+
+#include "comPrim.h"
+#include "PointerSrc.h"
+
+#if (defined(__CYGWIN32__) || defined(__MINGW32__)) && __W32API_MAJOR_VERSION == 1
+typedef LONG DISPID;
+#define DISPATCH_METHOD         0x1
+#define DISPATCH_PROPERTYGET    0x2
+#define DISPATCH_PROPERTYPUT    0x4
+#define DISPATCH_PROPERTYPUTREF 0x8
+
+#define	DISPID_VALUE	         (0)
+#define	DISPID_UNKNOWN	        (-1)
+#define	DISPID_PROPERTYPUT	(-3)
+#define	DISPID_NEWENUM	        (-4)
+#define	DISPID_EVALUATE	        (-5)
+#define	DISPID_CONSTRUCTOR	(-6)
+#define	DISPID_DESTRUCTOR	(-7)
+
+typedef LONG SCODE;
+
+enum VARENUM
+    {	VT_EMPTY	= 0,
+	VT_NULL	= 1,
+	VT_I2	= 2,
+	VT_I4	= 3,
+	VT_R4	= 4,
+	VT_R8	= 5,
+	VT_CY	= 6,
+	VT_DATE	= 7,
+	VT_BSTR	= 8,
+	VT_DISPATCH	= 9,
+	VT_ERROR	= 10,
+	VT_BOOL	= 11,
+	VT_VARIANT	= 12,
+	VT_UNKNOWN	= 13,
+	VT_DECIMAL	= 14,
+	VT_I1	= 16,
+	VT_UI1	= 17,
+	VT_UI2	= 18,
+	VT_UI4	= 19,
+	VT_I8	= 20,
+	VT_UI8	= 21,
+	VT_INT	= 22,
+	VT_UINT	= 23,
+	VT_VOID	= 24,
+	VT_HRESULT	= 25,
+	VT_PTR	= 26,
+	VT_SAFEARRAY	= 27,
+	VT_CARRAY	= 28,
+	VT_USERDEFINED	= 29,
+	VT_LPSTR	= 30,
+	VT_LPWSTR	= 31,
+	VT_FILETIME	= 64,
+	VT_BLOB	= 65,
+	VT_STREAM	= 66,
+	VT_STORAGE	= 67,
+	VT_STREAMED_OBJECT	= 68,
+	VT_STORED_OBJECT	= 69,
+	VT_BLOB_OBJECT	= 70,
+	VT_CF	= 71,
+	VT_CLSID	= 72,
+	VT_BSTR_BLOB	= 0xfff,
+	VT_VECTOR	= 0x1000,
+	VT_ARRAY	= 0x2000,
+	VT_BYREF	= 0x4000,
+	VT_RESERVED	= 0x8000,
+	VT_ILLEGAL	= 0xffff,
+	VT_ILLEGALMASKED	= 0xfff,
+	VT_TYPEMASK	= 0xfff
+    };
+
+typedef struct ITypeInfo ITypeInfo;
+
+typedef struct tagEXCEPINFO 
+{
+  unsigned short wCode;
+  unsigned short wReserved;
+  BSTR bstrSource;
+  BSTR bstrDescription;
+  BSTR bstrHelpFile;
+  unsigned long dwHelpContext;
+  void* pvReserved;
+  HRESULT (STDCALL *pfnDeferredFillIn) (struct tagEXCEPINFO*);
+  SCODE scode;
+} EXCEPINFO;
+
+typedef unsigned short VARTYPE;
+typedef short VARIANT_BOOL;
+typedef VARIANT_BOOL _VARIANT_BOOL;
+typedef double DATE;
+
+#if 0
+typedef unsigned long long ULONGLONG;
+#endif
+
+typedef struct tagCY {
+    unsigned long Lo;
+    long      Hi;
+} CY;
+
+typedef struct IDispatch IDispatch;
+
+typedef struct tagDEC {
+    USHORT wReserved;
+    BYTE  scale;
+    BYTE  sign;
+    ULONG Hi32;
+    unsigned long long Lo64;
+} DECIMAL;
+
+typedef struct tagSAFEARRAY SAFEARRAY;
+
+typedef struct tagVARIANT VARIANT;
+
+struct tagVARIANT 
+{
+  union {
+   struct __tagVARIANT {
+    VARTYPE vt;
+    WORD wReserved1;
+    WORD wReserved2;
+    WORD wReserved3;
+    union {
+      LONG           lVal;
+      BYTE           bVal;
+      SHORT          iVal;
+      FLOAT          fltVal;
+      double         dblVal;
+      VARIANT_BOOL   boolVal;
+      _VARIANT_BOOL  bool;
+      SCODE          scode;
+      CY             cyVal;
+      DATE           date;
+      BSTR           bstrVal;
+      IUnknown*      punkVal;
+      IDispatch*     pdispVal;
+      SAFEARRAY*     parray;
+      BYTE*          pbVal;
+      SHORT*         piVal;
+      LONG*          plVal;
+      FLOAT*         pfltVal;
+      double*        pdblVal;
+      VARIANT_BOOL*  pboolVal;
+      _VARIANT_BOOL* pbool;
+      SCODE*      pscode;
+      CY*         pcyVal;
+      DATE*       pdate;
+      BSTR*       pbstrVal;
+      IUnknown**  ppunkVal;
+      IDispatch** ppdispVal;
+      SAFEARRAY** pparray;
+      VARIANT*    pvarVal;
+      PVOID       byref;
+      CHAR        cVal;
+      USHORT      uiVal;
+      ULONG       ulVal;
+      INT         intVal;
+      UINT        uintVal;
+      DECIMAL*    pdecVal;
+      CHAR*       pcVal;
+      USHORT*     puiVal;
+      ULONG*      pulVal;
+      INT*        pintVal;
+      UINT*       puintVal;
+      } n3;
+   } n2;
+   DECIMAL decVal;
+  } n1;
+};
+
+typedef VARIANT VARIANTARG;
+
+
+typedef struct tagDISPPARAMS 
+{
+  VARIANTARG*  rgvarg;
+  DISPID*      rgdispidNamedArgs;
+  unsigned int cArgs;
+  unsigned int cNamedArgs;
+} DISPPARAMS;
+
+typedef struct IDispatchVtbl
+    {
+        HRESULT ( STDCALL  *QueryInterface )
+	   		( IDispatch  * This
+			, REFIID riid
+			, void  **ppvObject
+			);
+        
+        ULONG ( STDCALL  *AddRef )( IDispatch  * This );
+        
+        ULONG ( STDCALL  *Release )( IDispatch  * This );
+        
+        HRESULT ( STDCALL  *GetTypeInfoCount )
+			( IDispatch  * This
+			, UINT  *pctinfo
+			);
+        
+        HRESULT ( STDCALL *GetTypeInfo )
+	                ( IDispatch  *This
+			, UINT iTInfo
+			, LCID lcid
+			,ITypeInfo  **ppTInfo
+			);
+        
+        HRESULT ( STDCALL  *GetIDsOfNames )
+	                ( IDispatch  *This
+			, REFIID riid
+			, LPOLESTR  *rgszNames
+			, UINT cNames
+			, LCID lcid
+			, DISPID  *rgDispId
+			);
+        
+        HRESULT ( STDCALL  *Invoke )
+	                ( IDispatch  *This
+			, DISPID dispIdMember
+			, REFIID riid
+			, LCID lcid
+			, WORD wFlags
+			, DISPPARAMS  *pDispParams
+			, VARIANT  *pVarResult
+			, EXCEPINFO  *pExcepInfo
+			,UINT  *puArgErr
+			);
+
+    } IDispatchVtbl;
+
+struct IDispatch { struct IDispatchVtbl *lpVtbl; };
+#endif
+
+
+#if !defined(IDispatch_GetIDsOfNames)
+#define IDispatch_GetIDsOfNames(This,riid,rgszNames,cNames,lcid,rgDispId)	\
+    (This)->lpVtbl -> GetIDsOfNames(This,riid,rgszNames,cNames,lcid,rgDispId)
+#endif
+
+#if !defined(IDispatch_Invoke)
+#define IDispatch_Invoke(This,dispIdMember,riid,lcid,wFlags,pDispParams,pVarResult,pExcepInfo,puArgErr)	\
+    (This)->lpVtbl -> Invoke(This,dispIdMember,riid,lcid,wFlags,pDispParams,pVarResult,pExcepInfo,puArgErr)
+#endif
+
+#if __W32API_MAJOR_VERSION == 1
+extern void STDCALL VariantInit(VARIANTARG* pvarg);
+extern HRESULT STDCALL VariantClear(VARIANTARG* pvarg);
+extern HRESULT STDCALL VariantCopy(VARIANTARG* pvArgDest, VARIANTARG* pvArgSrc);
+extern HRESULT STDCALL VariantChangeType( VARIANTARG* pvargDest
+				, VARIANTARG* pvarSrc
+				, unsigned short wFlags
+				, VARTYPE vt
+				);
+#endif
+
+extern int dispErrorUNKNOWNNAME(HRESULT hr);
+extern int dispErrorEXCEPTION(HRESULT hr);
+extern HRESULT readVarVariant( VARIANT* v, VARIANT* x );
+extern int readVariantTag( VARIANT* v );
+extern void writeVarVariant( VARIANT* x, VARIANT* v);
+extern HRESULT readVarCurrency( VARIANT* v, int* hi, int* lo );
+extern void writeVarCurrency( int hi, unsigned int lo, VARIANT* v );
+extern HRESULT readVarWord64( VARIANT* v, unsigned int* hi, unsigned int* lo );
+extern void writeVarWord64( unsigned int hi, unsigned int lo, VARIANT* v );
+extern HRESULT readVarNull( VARIANT* v );
+extern void writeVarNull( VARIANT* v );
+extern void writeVarEmpty( VARIANT* v );
+extern void writeVarOptional( VARIANT* v );
+extern void writeVarSAFEARRAY ( VARIANT* v, SAFEARRAY* sa, VARTYPE vt);
+extern HRESULT readVarSAFEARRAY  ( VARIANT* v, SAFEARRAY** sa, VARTYPE vt);
+
+#define READWRITEPROTO(htype,ctype) \
+extern void writeVar##htype( ctype x, VARIANT* v); \
+extern HRESULT readVar##htype( VARIANT* v, ctype* p)
+
+#define READWRITETEMPPROTO(htype,ctype) \
+extern void writeVar##htype( ctype x, VARIANT* v); \
+extern HRESULT readVar##htype( VARIANT* v, ctype* p, VARIANT** w)
+
+READWRITEPROTO(Short,int);
+READWRITEPROTO(Int,int);
+READWRITEPROTO(Word,unsigned int);
+READWRITEPROTO(Float,float);
+READWRITEPROTO(Double, double);
+READWRITEPROTO(Date, double);
+READWRITETEMPPROTO(String, BSTR);
+READWRITETEMPPROTO(Dispatch, IDispatch*);
+READWRITEPROTO(Bool, BOOL);
+READWRITETEMPPROTO(Unknown, IUnknown*);
+READWRITEPROTO(Byte, unsigned char);
+READWRITEPROTO(Error, int);
+
+extern void freeVariants( int count, VARIANT* p );
+extern HRESULT 
+dispatchGetMemberID( IDispatch* obj, BSTR name, LCID lcid, DISPID* dispid );
+extern char* getExcepInfoMessage( EXCEPINFO* info );
+extern void freeExcepInfo( EXCEPINFO* info );
+extern HRESULT 
+dispatchInvoke( IDispatch* obj, DISPID dispid, LCID lcid,
+                BOOL isfunction, unsigned flags,
+                int cargs, int cargsout,
+                VARIANT* args, VARIANT* argsout,
+                EXCEPINFO** info );
+
+extern
+HRESULT
+STDCALL
+SafeArrayDestroy
+ 	( /*[in]*/SAFEARRAY* psa 
+	);
+
+extern HRESULT primCopyVARIANT  ( VARIANT* p1, VARIANT* p2 );
+extern HRESULT primVARIANTClear ( VARIANT* p1 );
+
+extern HRESULT primClockToDate (/*[in]*/int ct, /*[out]*/double* pT);
+
+#endif /* __AUTOPRIM_H__ */
+
+ include/comPrim.h view
@@ -0,0 +1,651 @@+/*
+ To free ourselves from a couple of needless compiler/
+ header file dependencies, we provide a hand-written
+ set of definitions for IUnknown.
+*/
+#ifndef __COMPRIM_H__
+#define __COMPRIM_H__
+
+#define COBJMACROS
+#include <windows.h>
+
+#if defined(__MINGW32__) || defined(__CYGWIN32__)
+/* Get at w32api version; assume both mingw and cygwin use it. */
+#include <w32api.h>
+#endif
+
+#ifndef REFIID
+typedef GUID IID;
+#define REFIID const IID *
+#endif
+
+#ifndef REFCLSID
+#define REFCLSID const CLSID *
+#endif
+
+#define FACILITY_WIN32                   7
+#ifndef HRESULT_FROM_WIN32
+#define HRESULT_FROM_WIN32(x)   (x ? ((HRESULT) (((x) & 0x0000FFFF) | (FACILITY_WIN32 << 16) | 0x80000000)) : 0 )
+#endif
+
+#ifndef SUCCEEDED
+#define SUCCEEDED(hr)  ((hr) >= 0)
+#endif
+
+#if __W32API_MAJOR_VERSION == 1
+typedef WCHAR OLECHAR;
+typedef OLECHAR* LPOLESTR;
+typedef const OLECHAR* LPCOLESTR;
+
+typedef WCHAR* BSTR;
+#endif
+
+extern const IID IID_NULL;
+extern const IID IID_IUnknown;
+extern const IID IID_IClassFactory;
+
+#if __W32API_MAJOR_VERSION == 1
+typedef struct IUnknown IUnknown;
+
+typedef struct IUnknownVtbl {
+      HRESULT (STDCALL *QueryInterface) 
+                           ( IUnknown* This
+                           , REFIID riid
+                           , void** ppvObject
+                           );
+      ULONG   (STDCALL *AddRef)  ( IUnknown* This );
+      ULONG   (STDCALL *Release) ( IUnknown* This );
+} IUnknownVtbl;
+
+struct IUnknown { struct IUnknownVtbl* lpVtbl;};
+
+#define IUnknown_QueryInterface(this,riid,ppvObject)	\
+    (this)->lpVtbl->QueryInterface(this,riid,ppvObject)
+
+#define IUnknown_AddRef(this)	(this)->lpVtbl->AddRef(this)
+
+#define IUnknown_Release(this)	(this)->lpVtbl->Release(this)
+#endif
+
+#ifndef S_OK
+#define S_OK                      (HRESULT)0x00000000L
+#endif
+#ifndef S_OK
+#define S_FALSE                   (HRESULT)0x00000001L
+#endif
+#ifndef E_POINTER
+#define E_POINTER                 (HRESULT)0x80004003L
+#endif
+#ifndef E_OUTOFMEMORY
+#define E_OUTOFMEMORY             (HRESULT)0x8007000EL
+#endif
+#ifndef E_INVALIDARG
+#define E_INVALIDARG              (HRESULT)0x80070057L
+#endif
+#ifndef E_NOINTERFACE
+#define E_NOINTERFACE             (HRESULT)0x80004002L
+#endif
+#ifndef E_FAIL
+#define E_FAIL                    (HRESULT)0x80004005L
+#endif
+#ifndef CO_E_CLASSSTRING
+#define CO_E_CLASSSTRING          (HRESULT)0x800401F3L
+#endif
+#ifndef CO_E_CLSREG_INCONSISTENT
+#define CO_E_CLSREG_INCONSISTENT  (HRESULT)0x8000401FL
+#endif
+#ifndef DISP_E_EXCEPTION
+#define DISP_E_EXCEPTION          (HRESULT)0x80020009L
+#endif
+#ifndef DISP_E_UNKNOWNNAME
+#define DISP_E_UNKNOWNNAME        (HRESULT)0x80020006L
+#endif
+#ifndef DISP_E_BADPARAMCOUNT
+#define DISP_E_BADPARAMCOUNT      (HRESULT)0x8002000EL
+#endif
+#ifndef DISP_E_PARAMNOTFOUND
+#define DISP_E_PARAMNOTFOUND      (HRESULT)0x80020004L
+#endif
+#ifndef CLASS_E_NOAGGREGATION
+#define CLASS_E_NOAGGREGATION     (HRESULT)0x80040110L
+#endif
+#ifndef CLASS_E_CLASSNOTAVAILABLE
+#define CLASS_E_CLASSNOTAVAILABLE (HRESULT)0x80040111L
+#endif
+
+#ifndef FAILED
+#define FAILED(hr)   ((HRESULT)(hr)<0)
+#endif
+
+extern
+HRESULT
+STDCALL
+OleInitialize ( void* pvReserved );
+
+extern
+void
+STDCALL
+OleUninitialize ();
+
+extern
+HRESULT
+STDCALL
+CoCreateInstance (
+		  REFCLSID   rclsid,
+		  IUnknown*  pUnkOuter,
+		  DWORD      dwClsContext,
+		  REFIID     riid,
+		  void**     ppv);
+
+#if __W32API_MAJOR_VERSION == 1
+extern
+HRESULT
+STDCALL
+CoCreateInstanceEx (
+		  REFCLSID   rclsid,
+		  IUnknown*  pUnkOuter,
+		  DWORD      dwClsContext,
+		  void*      pServerInfo,
+		  ULONG      cmq,
+		  void*      pResults);
+
+extern
+HRESULT
+STDCALL
+CoRegisterClassObject (
+		  REFCLSID   rclsid,
+		  IUnknown*  pUnkOuter,
+		  DWORD      dwClsContext,
+		  DWORD      flags,
+		  DWORD**    pdwRegister);
+#endif
+
+extern
+HRESULT
+STDCALL
+CoRevokeClassObject (
+		  DWORD      dwRegister
+                    );
+
+extern
+HRESULT
+STDCALL
+primCreateInstance (
+		  CLSID*     clsid,
+		  IUnknown*  pUnkOuter,
+		  DWORD      dwClsContext,
+		  IID*       iid,
+		  void**     ppv);
+extern
+HRESULT
+STDCALL
+StringFromCLSID
+             (REFCLSID rclsid,
+	      WCHAR** lplpsz);
+
+extern
+int
+STDCALL
+StringFromGUID2
+             ( const GUID* rguid
+	     , LPOLESTR    lpsz
+	     , int         cbMax
+	     );
+
+extern
+HRESULT
+STDCALL
+ProgIDFromCLSID
+             (REFCLSID rclsid,
+	      WCHAR** lplpsz);
+
+extern
+HRESULT
+STDCALL
+CLSIDFromString
+             (WCHAR* lpsz,
+	      CLSID* pclsid);
+
+/* Helper functions defined in ComPrimSrc.c */
+extern HRESULT primStringToGUID( WCHAR* guidStr, GUID* guid );
+extern char*   hresultString( HRESULT hr );
+extern HRESULT primGUIDToString( CLSID* guid, WCHAR** guidStr );
+extern DWORD   lOCALE_USER_DEFAULT ();
+extern IID*    primNullIID();
+
+extern HRESULT primQI (void* methPtr, void* iptr, void* rclsid, void** ppv);
+extern unsigned int primAddRef (void* methPtr, void* iptr);
+extern unsigned int primRelease(void* methPtr, void* iptr);
+
+extern void releaseIUnknown__(void* iptr);
+extern void* addrOfReleaseIUnknown();
+
+extern HRESULT primEnumNext (void* methPtr, void* iptr, unsigned int celt, void* ptr, void* po);
+extern HRESULT primEnumSkip (void* methPtr, void* iptr, unsigned int celt);
+extern HRESULT primEnumReset (void* methPtr, void* iptr);
+extern HRESULT primEnumClone (void* methPtr, void* iptr,void* ppv);
+
+extern HRESULT primPersistLoad(void* methPtr, void* iptr, void* pszFileName, unsigned int dwMode);
+
+extern HRESULT bstrToStringLen( BSTR bstr, int len, char* p );
+extern int     bstrLen( BSTR bstr );
+extern HRESULT stringToBSTR( const char* p, BSTR* pbstr );
+
+#if __W32API_MAJOR_VERSION == 1
+typedef struct IRunningObjectTable IRunningObjectTable;
+typedef struct IEnumString IEnumString;
+/* Close enough for our purposes.. */
+typedef int BIND_OPTS;
+
+typedef struct IBindCtx IBindCtx;
+
+    typedef struct IBindCtxVtbl
+    {
+        HRESULT ( STDCALL *QueryInterface )
+	           ( IBindCtx * This
+		   , REFIID riid
+		   , void **ppvObject
+		   );
+        
+        ULONG ( STDCALL *AddRef )( IBindCtx * This );
+        
+        ULONG ( STDCALL *Release )( IBindCtx * This );
+        
+        HRESULT ( STDCALL *RegisterObjectBound )
+	           ( IBindCtx * This
+		   , IUnknown *punk
+		   );
+        
+        HRESULT ( STDCALL *RevokeObjectBound )
+	           ( IBindCtx * This
+		   , IUnknown *punk
+		   );
+        
+        HRESULT ( STDCALL *ReleaseBoundObjects )
+	           ( IBindCtx * This );
+        
+        /* [local] */ HRESULT ( STDCALL *SetBindOptions )
+	           ( IBindCtx * This
+		   , BIND_OPTS *pbindopts
+		   );
+        
+        /* [local] */ HRESULT ( STDCALL *GetBindOptions )
+	           ( IBindCtx * This
+		   , BIND_OPTS *pbindopts
+		   );
+        
+        HRESULT ( STDCALL *GetRunningObjectTable )
+	           ( IBindCtx * This
+		   , IRunningObjectTable **pprot
+		   );
+        
+        HRESULT ( STDCALL *RegisterObjectParam )
+	           ( IBindCtx * This
+		   , LPOLESTR pszKey
+		   , IUnknown *punk
+		   );
+        
+        HRESULT ( STDCALL *GetObjectParam )
+	           ( IBindCtx * This
+		   , LPOLESTR pszKey
+		   , IUnknown **ppunk
+		   );
+        
+        HRESULT ( STDCALL *EnumObjectParam )
+	           ( IBindCtx * This
+		   , IEnumString **ppenum
+		   );
+        
+        HRESULT ( STDCALL *RevokeObjectParam )
+	           ( IBindCtx * This
+		   , LPOLESTR pszKey
+		   );
+    } IBindCtxVtbl;
+
+struct IBindCtx { struct IBindCtxVtbl *lpVtbl; };
+
+typedef struct IStream IStream;
+typedef struct IEnumMoniker IEnumMoniker;
+
+typedef struct IMoniker IMoniker;
+    typedef struct IMonikerVtbl
+    {
+        HRESULT ( STDCALL *QueryInterface )
+	           ( IMoniker * This
+		   , REFIID riid
+		   , void **ppvObject
+		   );
+        
+        ULONG ( STDCALL *AddRef )( IMoniker * This );
+        
+        ULONG ( STDCALL *Release )( IMoniker * This );
+
+        HRESULT ( STDCALL *GetClassID )
+	           ( IMoniker * This
+		   , CLSID *pClassID
+		   );
+        
+        HRESULT ( STDCALL *IsDirty )( IMoniker * This );
+        
+        HRESULT ( STDCALL *Load )
+	           ( IMoniker * This
+		   , IStream *pStm
+		   );
+        
+        HRESULT ( STDCALL *Save )
+	           ( IMoniker * This
+		   , IStream *pStm
+		   , BOOL fClearDirty
+		   );
+        
+        HRESULT ( STDCALL *GetSizeMax )
+	           ( IMoniker * This
+		   , ULARGE_INTEGER *pcbSize
+		   );
+        
+        HRESULT ( STDCALL *BindToObject )
+	           ( IMoniker * This
+		   , IBindCtx *pbc
+		   , IMoniker *pmkToLeft
+		   , REFIID riidResult
+		   , void **ppvResult
+		   );
+        
+        HRESULT ( STDCALL *BindToStorage )
+	           ( IMoniker * This
+		   , IBindCtx *pbc
+		   , IMoniker *pmkToLeft
+		   , REFIID riid
+		   , void **ppvObj
+		   );
+        
+        HRESULT ( STDCALL *Reduce )
+	           ( IMoniker * This
+		   , IBindCtx *pbc
+		   , DWORD dwReduceHowFar
+		   , IMoniker **ppmkToLeft
+		   , IMoniker **ppmkReduced
+		   );
+        
+        HRESULT ( STDCALL *ComposeWith )
+	           ( IMoniker * This
+		   , IMoniker *pmkRight
+		   , BOOL fOnlyIfNotGeneric
+		   , IMoniker **ppmkComposite
+		   );
+        
+        HRESULT ( STDCALL *Enum )
+	           ( IMoniker * This
+		   , BOOL fForward
+		   , IEnumMoniker **ppenumMoniker
+		   );
+        
+        HRESULT ( STDCALL *IsEqual )
+	           ( IMoniker * This
+		   , IMoniker *pmkOtherMoniker
+		   );
+        
+        HRESULT ( STDCALL *Hash )
+	           ( IMoniker * This
+		   , DWORD *pdwHash
+		   );
+        
+        HRESULT ( STDCALL *IsRunning )
+	           ( IMoniker * This
+		   , IBindCtx *pbc
+		   , IMoniker *pmkToLeft
+		   , IMoniker *pmkNewlyRunning
+		   );
+        
+        HRESULT ( STDCALL *GetTimeOfLastChange )
+	           ( IMoniker * This
+		   , IBindCtx *pbc
+		   , IMoniker *pmkToLeft
+		   , FILETIME *pFileTime
+		   );
+        
+        HRESULT ( STDCALL *Inverse )
+	           ( IMoniker * This
+		   , IMoniker **ppmk
+		   );
+        
+        HRESULT ( STDCALL *CommonPrefixWith )
+	           ( IMoniker * This
+		   , IMoniker *pmkOther
+		   , IMoniker **ppmkPrefix
+		   );
+        
+        HRESULT ( STDCALL *RelativePathTo )
+	           ( IMoniker * This
+		   , IMoniker *pmkOther
+		   , IMoniker **ppmkRelPath
+		   );
+        
+        HRESULT ( STDCALL *GetDisplayName )
+	           ( IMoniker * This
+		   , IBindCtx *pbc
+		   , IMoniker *pmkToLeft
+		   , LPOLESTR *ppszDisplayName
+		   );
+        
+        HRESULT ( STDCALL *ParseDisplayName )
+	           ( IMoniker * This
+		   , IBindCtx *pbc
+		   , IMoniker *pmkToLeft
+		   , LPOLESTR pszDisplayName
+		   , ULONG *pchEaten
+		   , IMoniker **ppmkOut
+		   );
+        
+        HRESULT ( STDCALL *IsSystemMoniker )
+	           ( IMoniker * This
+		   , DWORD *pdwMksys
+		   );
+    } IMonikerVtbl;
+
+struct IMoniker { struct IMonikerVtbl* lpVtbl; };
+
+#define IMoniker_BindToObject(This,pbc,pmkToLeft,riidResult,ppvResult)	\
+    (This)->lpVtbl -> BindToObject(This,pbc,pmkToLeft,riidResult,ppvResult)
+
+typedef struct IEnumUnknown IEnumUnknown;
+
+typedef struct IEnumUnknownVtbl
+    {
+        HRESULT ( STDCALL *QueryInterface )
+	            ( IEnumUnknown * This
+		    , REFIID riid
+		    , void **ppvObject
+		    );
+        
+        ULONG ( STDCALL *AddRef )( IEnumUnknown * This );
+        
+        ULONG ( STDCALL *Release )( IEnumUnknown * This );
+        
+        HRESULT ( STDCALL *Next )
+	            ( IEnumUnknown * This
+		    , ULONG celt
+		    , IUnknown **rgelt
+		    , ULONG *pceltFetched
+		    );
+        
+        HRESULT ( STDCALL *Skip )
+	            ( IEnumUnknown * This
+		    , ULONG celt
+		    );
+        
+        HRESULT ( STDCALL *Reset )(  IEnumUnknown * This );
+        
+        HRESULT ( STDCALL *Clone )( IEnumUnknown * This, IEnumUnknown **ppenum );
+
+    } IEnumUnknownVtbl;
+
+struct IEnumUnknown { IEnumUnknownVtbl* lpVtbl; };
+
+extern
+void*
+STDCALL
+CoTaskMemAlloc(unsigned int size);
+
+void
+STDCALL
+CoTaskMemFree(LPVOID pv);
+
+extern
+HRESULT
+STDCALL
+GetActiveObject (CLSID* clsid, void* reserved, IUnknown** ppunk);
+
+extern BSTR STDCALL SysAllocStringLen(OLECHAR* pch, unsigned int cch);
+extern BSTR STDCALL SysAllocStringByteLen(char* pch, unsigned int len);
+extern void STDCALL SysFreeString(BSTR bstr);
+extern UINT STDCALL SysStringLen(BSTR bstr);
+#endif
+
+extern
+HRESULT
+STDCALL
+MkParseDisplayName( IBindCtx* pbc
+		  , LPCOLESTR szUserName
+		  , unsigned long* eatern
+		  , IMoniker** ppmk);
+
+extern
+HRESULT
+STDCALL
+CreateBindCtx (DWORD reserved, IBindCtx** ppbc);
+
+#if __W32API_MAJOR_VERSION == 1
+extern
+HRESULT
+STDCALL CreateTypeLib ( int syskind, LPCOLESTR szFile, void** ppv);
+
+extern
+HRESULT
+STDCALL CoCreateGuid ( GUID* pguid );
+
+extern
+HRESULT
+STDCALL CreateTypeLib2 ( int syskind, LPCOLESTR szFile, void** ppv);
+#endif
+
+#ifndef STR2UNI 
+#define STR2UNI(unistr, regstr) mbstowcs (unistr, regstr, strlen (regstr)+1)
+#define UNI2STR(regstr, unistr) wcstombs (regstr, unistr, wcslen (unistr)+1)
+#endif 
+
+#if __W32API_MAJOR_VERSION == 1
+BOOL
+STDCALL
+IsEqualGUID (const GUID* g1, const GUID* g2);
+
+HRESULT
+STDCALL
+LoadTypeLib
+             ( LPOLESTR    lpsz
+	     , IUnknown**  ppv
+	     );
+
+HRESULT
+STDCALL
+LoadTypeLibEx
+             ( LPOLESTR    lpsz
+	     , int         kind
+	     , IUnknown**  ppv
+	     );
+
+HRESULT
+STDCALL
+LoadRegTypeLib
+             ( GUID*       rguid
+	     , WORD        wVerMajor
+	     , WORD        wVerMinor
+	     , LCID        lcid
+	     , IUnknown**  ppv
+	     );
+#endif
+
+extern
+HRESULT
+primLoadRegTypeLib 
+                ( GUID* rguid
+		, short wMaj
+		, short wMin
+		, LCID lcid
+		, void** ppv
+		);
+
+#if __W32API_MAJOR_VERSION == 1
+extern
+HRESULT
+STDCALL
+QueryPathOfRegTypeLib
+             ( GUID* rguid
+	     , unsigned short maj
+	     , unsigned short min
+	     , LCID  lcid
+	     , BSTR* pbstr
+	     );
+
+#endif
+
+extern
+BSTR
+primQueryPathOfRegTypeLib
+             ( GUID* rguid
+	     , unsigned short maj
+	     , unsigned short min
+	     );
+
+extern
+char*
+getModuleFileName
+             ( HANDLE hMod
+	     );
+
+#if __W32API_MAJOR_VERSION == 1
+extern
+DWORD
+WINAPI
+GetModuleFileNameA
+             ( HINSTANCE hMod
+	     , LPSTR     lpFileName
+	     , DWORD     size
+	     );
+
+extern
+LCID
+WINAPI
+GetUserDefaultLCID
+             ();
+
+extern
+INT
+STDCALL
+SystemTimeToVariantTime (void* lpSystemTime, double* pvarTime);
+#endif
+
+extern void    messageBox (char* str, char* t, unsigned long x);
+extern HRESULT primCreateTypeLib ( int i, LPOLESTR fname, void** ppv );
+extern BOOL    primComEqual( IUnknown* unk1, IUnknown* unk2 );
+extern HRESULT primCopyGUID( GUID* g1, GUID* g2);
+extern HRESULT primNewGUID( GUID* g1);
+extern HRESULT bindObject( const WCHAR* name, IID* iid, void** unk );
+extern HRESULT primProgIDFromCLSID( const CLSID* clsid, WCHAR** clsidStr );
+extern HRESULT primCLSIDFromProgID( const char* progid, CLSID* clsid );
+extern void    comUnInitialize(void);
+extern HRESULT comInitialize(void);
+extern HRESULT primStringToGUID( WCHAR* guidStr, GUID* guid );
+extern HRESULT primGUIDToString( CLSID* guid, WCHAR** guidStr );
+
+extern void    postQuitMsg();
+extern void    messagePump();
+extern void*   finalNoFree();
+
+extern HANDLE  mkEvent();
+extern void    waitForEvent(HANDLE h);
+extern void    signalEvent(HANDLE h);
+
+extern void primGetVersionInfo ( unsigned long*, unsigned long*, unsigned long*);
+
+#endif /* __COMPRIM_H__ */
+ include/safeArrayPrim.h view
@@ -0,0 +1,2 @@+
+extern void primSafeArrayDestroy (void* p);