diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,9 @@ +#!/usr/bin/runhugs + +> module Main where + +> import Distribution.Simple + +> main :: IO () +> main = defaultMain + diff --git a/System/Win32/Com.hs b/System/Win32/Com.hs new file mode 100644 --- /dev/null +++ b/System/Win32/Com.hs @@ -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 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 "" + +{- +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 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 diff --git a/System/Win32/Com/Automation.hs b/System/Win32/Com/Automation.hs new file mode 100644 --- /dev/null +++ b/System/Win32/Com/Automation.hs @@ -0,0 +1,1958 @@ +{-# OPTIONS -#include "autoPrim.h" #-} +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.Com.Automation +-- Copyright : (c) Daan Leijen , Sigbjorn Finne 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 + diff --git a/System/Win32/Com/Automation/Base.hs b/System/Win32/Com/Automation/Base.hs new file mode 100644 --- /dev/null +++ b/System/Win32/Com/Automation/Base.hs @@ -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 + diff --git a/System/Win32/Com/Automation/Connection.hs b/System/Win32/Com/Automation/Connection.hs new file mode 100644 --- /dev/null +++ b/System/Win32/Com/Automation/Connection.hs @@ -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 + + diff --git a/System/Win32/Com/Automation/SafeArray.hs b/System/Win32/Com/Automation/SafeArray.hs new file mode 100644 --- /dev/null +++ b/System/Win32/Com/Automation/SafeArray.hs @@ -0,0 +1,316 @@ +{-# OPTIONS -#include #-} +{-# 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 +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-} + diff --git a/System/Win32/Com/Automation/StdTypes.hs b/System/Win32/Com/Automation/StdTypes.hs new file mode 100644 --- /dev/null +++ b/System/Win32/Com/Automation/StdTypes.hs @@ -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 +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 " + + diff --git a/System/Win32/Com/Automation/TypeLib.hs b/System/Win32/Com/Automation/TypeLib.hs new file mode 100644 --- /dev/null +++ b/System/Win32/Com/Automation/TypeLib.hs @@ -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 + diff --git a/System/Win32/Com/Base.hs b/System/Win32/Com/Base.hs new file mode 100644 --- /dev/null +++ b/System/Win32/Com/Base.hs @@ -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 + diff --git a/System/Win32/Com/ClassFactory.hs b/System/Win32/Com/ClassFactory.hs new file mode 100644 --- /dev/null +++ b/System/Win32/Com/ClassFactory.hs @@ -0,0 +1,95 @@ +{-# OPTIONS -#include "ClassFactory_stub.h" #-} +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.Com.ClassFactory +-- Copyright : (c) Sigbjorn Finne 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] diff --git a/System/Win32/Com/Dll.hs b/System/Win32/Com/Dll.hs new file mode 100644 --- /dev/null +++ b/System/Win32/Com/Dll.hs @@ -0,0 +1,308 @@ +{-# OPTIONS -#include "System/Win32/Com/Dll_stub.h" -#include -#include "Registry.h" #-} +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.Com.Dll +-- Copyright : (c) Sigbjorn Finne 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 () diff --git a/System/Win32/Com/Exception.hs b/System/Win32/Com/Exception.hs new file mode 100644 --- /dev/null +++ b/System/Win32/Com/Exception.hs @@ -0,0 +1,798 @@ +{-# OPTIONS -#include "comPrim.h" #-} +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.Com.Exception +-- Copyright : (c) Sigbjorn Finne 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) diff --git a/System/Win32/Com/HDirect/HDirect.hs b/System/Win32/Com/HDirect/HDirect.hs new file mode 100644 --- /dev/null +++ b/System/Win32/Com/HDirect/HDirect.hs @@ -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 + diff --git a/System/Win32/Com/HDirect/Pointer.hs b/System/Win32/Com/HDirect/Pointer.hs new file mode 100644 --- /dev/null +++ b/System/Win32/Com/HDirect/Pointer.hs @@ -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) diff --git a/System/Win32/Com/HDirect/PointerPrim.hs b/System/Win32/Com/HDirect/PointerPrim.hs new file mode 100644 --- /dev/null +++ b/System/Win32/Com/HDirect/PointerPrim.hs @@ -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 () + diff --git a/System/Win32/Com/HDirect/WideString.hs b/System/Win32/Com/HDirect/WideString.hs new file mode 100644 --- /dev/null +++ b/System/Win32/Com/HDirect/WideString.hs @@ -0,0 +1,152 @@ +{-# OPTIONS -#include #-} +{-# 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 + diff --git a/System/Win32/Com/Server.hs b/System/Win32/Com/Server.hs new file mode 100644 --- /dev/null +++ b/System/Win32/Com/Server.hs @@ -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 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 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) diff --git a/System/Win32/Com/Server/ClassInfo.hs b/System/Win32/Com/Server/ClassInfo.hs new file mode 100644 --- /dev/null +++ b/System/Win32/Com/Server/ClassInfo.hs @@ -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 ()) diff --git a/System/Win32/Com/Server/ConnectionPoint.hs b/System/Win32/Com/Server/ConnectionPoint.hs new file mode 100644 --- /dev/null +++ b/System/Win32/Com/Server/ConnectionPoint.hs @@ -0,0 +1,218 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.Com.Server.ConnectionPoint +-- Copyright : (c) Sigbjorn Finne 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 diff --git a/System/Win32/Com/Server/EnumInterface.hs b/System/Win32/Com/Server/EnumInterface.hs new file mode 100644 --- /dev/null +++ b/System/Win32/Com/Server/EnumInterface.hs @@ -0,0 +1,149 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.Com.Server.EnumInterface +-- Copyright : (c) Sigbjorn Finne 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 ()) diff --git a/System/Win32/Com/Server/ExeServer.hs b/System/Win32/Com/Server/ExeServer.hs new file mode 100644 --- /dev/null +++ b/System/Win32/Com/Server/ExeServer.hs @@ -0,0 +1,97 @@ +{-# OPTIONS -#include "comPrim.h" #-} +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.Com.Server.ExeServer +-- Copyright : (c) Sigbjorn Finne 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 + + diff --git a/System/Win32/Com/Server/StdDispatch.hs b/System/Win32/Com/Server/StdDispatch.hs new file mode 100644 --- /dev/null +++ b/System/Win32/Com/Server/StdDispatch.hs @@ -0,0 +1,493 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Win32.Com.Server.StdDispatch +-- Copyright : (c) Sigbjorn Finne 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 + 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 + 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 + diff --git a/cbits/AutoPrimSrc.c b/cbits/AutoPrimSrc.c new file mode 100644 --- /dev/null +++ b/cbits/AutoPrimSrc.c @@ -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 +#include + +#if defined(__CYGWIN32__) || defined(__MINGW32__) +#include +#endif + +#ifdef __GNUC__ +#include "comPrim.h" +#include "autoPrim.h" +#include "PointerSrc.h" +#include +#include + +/* 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 + +} diff --git a/cbits/ComPrimSrc.c b/cbits/ComPrimSrc.c new file mode 100644 --- /dev/null +++ b/cbits/ComPrimSrc.c @@ -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 + +#ifdef _MSC_VER +#include +#else +#include +#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__; +} diff --git a/cbits/PointerSrc.c b/cbits/PointerSrc.c new file mode 100644 --- /dev/null +++ b/cbits/PointerSrc.c @@ -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 + +#if !defined(__BASTARDIZED_WIN32__) && defined(COM) +#include +#else +# if defined(__BASTARDIZED_WIN32__) + #include +# if defined(__BASTARDIZED_WIN32__) && defined(COM) + #include "comPrim.h" +# endif +# endif +#include +#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; } diff --git a/cbits/Registry.c b/cbits/Registry.c new file mode 100644 --- /dev/null +++ b/cbits/Registry.c @@ -0,0 +1,254 @@ +/* + Misc helper functions for accessing the registry. +*/ +#include +#include +#include +#include +#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 diff --git a/cbits/SafeArrayPrim.c b/cbits/SafeArrayPrim.c new file mode 100644 --- /dev/null +++ b/cbits/SafeArrayPrim.c @@ -0,0 +1,10 @@ + +#include "autoPrim.h" +#include "SafeArrayPrim.h" + +/* Finaliser for SAFEARRAYs */ +void +primSafeArrayDestroy(void* p) +{ + SafeArrayDestroy((SAFEARRAY*)p); +} diff --git a/cbits/WideStringSrc.c b/cbits/WideStringSrc.c new file mode 100644 --- /dev/null +++ b/cbits/WideStringSrc.c @@ -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 + +#if defined(_WIN32) && !defined(__CYGWIN32__) +#include +#define WCHAR wchar_t +#else + #ifdef __CYGWIN32__ + #include + #endif +#include +#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); +} diff --git a/com.cabal b/com.cabal new file mode 100644 --- /dev/null +++ b/com.cabal @@ -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 +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 +} diff --git a/include/HDirect.h b/include/HDirect.h new file mode 100644 --- /dev/null +++ b/include/HDirect.h @@ -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__ */ diff --git a/include/PointerSrc.h b/include/PointerSrc.h new file mode 100644 --- /dev/null +++ b/include/PointerSrc.h @@ -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__ */ diff --git a/include/Registry.h b/include/Registry.h new file mode 100644 --- /dev/null +++ b/include/Registry.h @@ -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 diff --git a/include/SafeArray.h b/include/SafeArray.h new file mode 100644 --- /dev/null +++ b/include/SafeArray.h @@ -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 +#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 diff --git a/include/StdTypes.h b/include/StdTypes.h new file mode 100644 --- /dev/null +++ b/include/StdTypes.h @@ -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 +#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 diff --git a/include/WideStringSrc.h b/include/WideStringSrc.h new file mode 100644 --- /dev/null +++ b/include/WideStringSrc.h @@ -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 diff --git a/include/autoPrim.h b/include/autoPrim.h new file mode 100644 --- /dev/null +++ b/include/autoPrim.h @@ -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__ */ + diff --git a/include/comPrim.h b/include/comPrim.h new file mode 100644 --- /dev/null +++ b/include/comPrim.h @@ -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 + +#if defined(__MINGW32__) || defined(__CYGWIN32__) +/* Get at w32api version; assume both mingw and cygwin use it. */ +#include +#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__ */ diff --git a/include/safeArrayPrim.h b/include/safeArrayPrim.h new file mode 100644 --- /dev/null +++ b/include/safeArrayPrim.h @@ -0,0 +1,2 @@ + +extern void primSafeArrayDestroy (void* p);