com-1.2.1: System/Win32/Com.hs
{-# 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
, ComException(..)
, catchComException
, throwIOComException
, throwComException
-- 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 Control.Exception ( 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 <-
catchComException io
(\ err -> do
when (isCoError err) (putMessage $ coGetErrorString err)
coUnInitialize
throwIOComException err)
coUnInitialize
return v
coPerformIO :: IO a -> IO a
coPerformIO io =
catchComException io
( \ err -> do
putMessage (coGetErrorString err)
throwIOComException err
)
coUnsafePerformIO :: IO a -> a
coUnsafePerformIO = unsafePerformIO . coPerformIO
printMessage :: Show a => a -> IO ()
printMessage x = putMessage (show x)
putMessage :: String -> IO ()
putMessage msg =
stackString msg $ \ _ m ->
stackString "Haskell message" $ \ _ t ->
Base.messageBox m t 0x40040
{- To mere mortals, that's MB_OK | MB_ICONINFORMATION | MB_TOPMOST :-) -}
messageBox :: String -> String -> Word32 -> IO ()
messageBox msg title flg =
stackString msg $ \ _ m ->
stackString title $ \ _ t ->
Base.messageBox m t flg
outputDebugString :: String -> IO ()
outputDebugString msg = primOutputDebugString ("haskell-com: " ++ msg ++ "\n")
{-
Really belongs elsewhere...getting info of what kind of
platform we're on.
-}
data OSVersionInfo
= OSVersionInfo Word32 Word32 Word32
isWindowsNT :: OSVersionInfo -> Bool
isWindowsNT (OSVersionInfo _ _ 2{-VER_PLATFORM_WIN32_NT-}) = True
isWindowsNT _ = False
isWindows95 :: OSVersionInfo -> Bool
isWindows95 (OSVersionInfo _ 0 1{-VER_PLATFORM_WIN32_WINDOWS-}) = True
isWindows95 _ = False
isWindows98 :: OSVersionInfo -> Bool
isWindows98 (OSVersionInfo _ x 1{-VER_PLATFORM_WIN32_WINDOWS-}) = x /= 0
isWindows98 _ = False
versionInfo :: OSVersionInfo
versionInfo = unsafePerformIO $ do
(j,n,d) <- primGetVersionInfo
return (OSVersionInfo j n d)
{-
Enumeration used by @comCreateInstance@ to specify execution
context in which we'd like to component to be created
(just use @AnyProcess@ if you're not fussed):
-}
data CLSCTX
= CLSCTX_INPROC_SERVER
| CLSCTX_INPROC_HANDLER
| CLSCTX_LOCAL_SERVER
| CLSCTX_INPROC_SERVER16
| CLSCTX_REMOTE_SERVER
| CLSCTX_INPROC_HANDLER16
| CLSCTX_INPROC_SERVERX86
| CLSCTX_INPROC_HANDLERX86
| LocalProcess
| InProcess
| ServerProcess
| AnyProcess
deriving (Show)
instance Enum CLSCTX where
fromEnum ctx =
case ctx of
CLSCTX_INPROC_SERVER -> 1
CLSCTX_INPROC_HANDLER -> 2
CLSCTX_LOCAL_SERVER -> 4
CLSCTX_INPROC_SERVER16 -> 8
CLSCTX_REMOTE_SERVER -> 16
CLSCTX_INPROC_HANDLER16 -> 32
CLSCTX_INPROC_SERVERX86 -> 64
CLSCTX_INPROC_HANDLERX86 -> 128
LocalProcess -> localProcess
InProcess -> inProcess
ServerProcess -> serverProcess
AnyProcess -> anyProcess
toEnum x =
case x of
1 -> CLSCTX_INPROC_SERVER
2 -> CLSCTX_INPROC_HANDLER
8 -> CLSCTX_INPROC_SERVER16
16 -> CLSCTX_REMOTE_SERVER
32 -> CLSCTX_INPROC_HANDLER16
64 -> CLSCTX_INPROC_SERVERX86
128 -> CLSCTX_INPROC_HANDLERX86
0x04 -> LocalProcess
0x0b -> InProcess
0x0d -> ServerProcess
4 -> CLSCTX_LOCAL_SERVER
_ -> AnyProcess
localProcess :: Int
localProcess = 0x04
inProcess :: Int
inProcess = 0x0b
serverProcess :: Int
serverProcess = 0x0d
anyProcess :: Int
anyProcess = 0x0f
--VTable method invocation wrappers:
invokeAndCheck :: (Ptr any -> Ptr b -> IO HRESULT) -> Int -> IUnknown a -> IO ()
invokeAndCheck meth offset iptr = do
hr <- primInvokeItFO meth offset (marshallIUnknown iptr)
checkHR hr
invokeIt :: (Ptr any -> Ptr c -> IO a) -> Int -> IUnknown b -> IO a
invokeIt meth offset iptr = primInvokeItFO meth offset (marshallIUnknown iptr)
{-
Library provided stubs for IEnum* interfaces - the HaskellDirect
knows how to generate code for these:
-}
enumNext :: Word32 -> (Ptr any -> IO a) -> Word32 -> IUnknown b -> IO [a]
enumNext szof read_elt celt iptr = do
ptr <- allocBytes (fromIntegral (celt * szof))
po <- allocBytes (fromIntegral sizeofWord32)
invokeIt (\ methPtr ip -> primEnumNext methPtr ip celt ptr po) 3 iptr
elts_read <- readWord32 (castPtr po)
v <- peek ((castPtr ptr) :: Ptr (Ptr a))
unmarshalllist szof 0 elts_read read_elt v
enumSkip :: Word32 -> IUnknown a -> IO ()
enumSkip count iptr =
invokeIt (\ methPtr ip -> primEnumSkip methPtr ip count) 4 iptr
enumReset :: IUnknown a -> IO ()
enumReset iptr =
invokeIt (\ methPtr ip -> primEnumReset methPtr ip) 5 iptr
enumClone :: IUnknown a -> IO (IUnknown b)
enumClone iptr = do
ppv <- allocOutPtr
invokeIt (\ methPtr ip -> primEnumClone methPtr ip ppv) 6 iptr
doThenFree free (readIUnknown False{-finalise only-}) ppv
{-
BSTRs were introduced by Automation, but their now used in non-Auto
contexts.
-}
data BSTR = BSTR
writeBSTR :: Ptr String -> String -> IO ()
writeBSTR ptr str =
stackString str $ \_ pstr -> do
o_stringToBSTR <- prim_System_Win32_Com_Base_stringToBSTR (castPtr pstr) ptr
checkHR o_stringToBSTR
--readBSTR :: Ptr BSTR -> IO String
readBSTR :: Ptr (Ptr String) -> IO String
readBSTR ptr = do
ptr' <- peek ptr
unmarshallBSTR ptr'
unmarshallBSTR :: Ptr String -> IO String
unmarshallBSTR bstr
| bstr == nullPtr = return ""
| len == 0 = return ""
| otherwise = do
stackStringLen (4 + fromIntegral len) "" $ \ pstr -> do
bstrToStringLen (castPtr bstr) len (castPtr pstr)
unmarshallString pstr
where
len = bstrLen (castPtr bstr)
marshallBSTR :: String -> IO (Ptr String)
marshallBSTR s =
stackString s $ \ _ pstr -> do
ptr <- stringToBSTR (castPtr pstr)
x <- peek (castPtr ptr)
free ptr
return x
freeBSTR x
| x == nullPtr = return ()
| otherwise = P.freeBSTR x
-- This type sometimes appear in IDL and tlbs, so
-- to avoid having to depend on wtypes for it, let's
-- simply define it here.
type LPSTR = String
coFree :: Ptr a -> IO ()
coFree p = freeMemory p
coAlloc :: Word32 -> IO (Ptr a)
coAlloc sz = allocMemory sz
type ProgID = String
clsidFromProgID :: ProgID -> IO CLSID
clsidFromProgID progid =
stackString progid $ \ _ pprogid -> do
pclsid <- coAlloc sizeofCLSID
coOnFail (primCLSIDFromProgID pprogid (castPtr pclsid))
("Component '" ++ progid ++ "' is unknown")
unmarshallCLSID True pclsid
progIDFromCLSID :: CLSID -> IO ProgID
progIDFromCLSID clsid = do
pclsid <- marshallCLSID clsid
pwide <- primProgIDFromCLSID (castForeignPtr pclsid)
(pstr,hr) <- wideToString (castPtr pwide)
checkHR hr
str <- unmarshallString (castPtr pstr)
coFree pstr
coFree pwide
return str
--Type libraries are identified by a GUID too:
type LIBID = GUID
mkLIBID :: String -> LIBID
mkLIBID = mkGUID
type LCID = Word32
{-
Representing interface pointers
To represent a (COM) interface pointer, we use the type <tt/IUnknown/,
which is parameterised over its interface:
-}
iidIUnknown :: IID (IUnknown ())
iidIUnknown = mkIID "{00000000-0000-0000-C000-000000000046}"
{-
Equality of interface pointers is defined by the COM spec
as being equality of IUnknown (pointers to) implementations.
-}
instance Eq (IUnknown_ a) where
iface1 == iface2 = coEqual (castIface iface1) (castIface iface2)
castIface :: IUnknown a -> IUnknown b
castIface (Unknown o) = Unknown o
interfaceNULL :: IUnknown a
interfaceNULL = unsafePerformIO (unmarshallIUnknown False nullPtr)
isNullInterface :: IUnknown a -> Bool
isNullInterface (Unknown ip) = foreignPtrToPtr ip == nullPtr
iidNULL :: IID ()
iidNULL = mkIID "{00000000-0000-0000-0000-000000000000}"
instance Show (IUnknown_ a) where
showsPrec _ iface =
shows "<interface pointer = " .
shows (ifaceToAddr iface) .
shows ">"
{-
Library provided stubs for IUnknown's methods:
(derived from H/Direct output)
-}
queryInterface :: IID (IUnknown b) -> IUnknown a -> IO (IUnknown b)
queryInterface riid iptr = do
ppvObject <- allocOutPtr
priid <- marshallIID riid
invokeIt (\ methPtr ip -> primQI methPtr ip (castForeignPtr priid) ppvObject) 0 iptr
doThenFree free (readIUnknown False{-finalise only-}) ppvObject
addRef :: IUnknown a -> IO Word32
addRef iptr = invokeIt (\ methPtr ip -> primAddRef methPtr ip) 1 iptr
release :: IUnknown a -> IO Word32
release iptr = invokeIt (\ methPtr ip -> primRelease methPtr ip) 2 iptr
withQueryInterface :: IID (IUnknown b)
-> IUnknown a
-> (IUnknown b -> IO c)
-> IO c
withQueryInterface iid unk action
= bracket (queryInterface iid unk) release action
--HDirect generated stub needed by @coGetObject@:
persistfileLoad :: IPersistFile a -> Ptr Wchar_t -> Word32 -> IO ()
persistfileLoad iptr pszFileName dwMode =
invokeIt (\ methPtr ip -> primPersistLoad methPtr ip pszFileName dwMode) 5 iptr
--GUIDs:
newtype GUID = GUID (ForeignPtr ()) --(Pointer Guid)
data Guid = Guid
mkGUID :: String -> GUID
mkGUID str = unsafePerformIO (stringToGUID str)
newGUID :: IO GUID
newGUID = do
pg <- coAlloc sizeofGUID
ng <- makeFO pg (castPtrToFunPtr finalFreeMemory)
primNewGUID ng
return (GUID ng)
nullGUID :: GUID
nullGUID = unsafePerformIO $ do
x <- primNullIID
p <- makeFO x (castPtrToFunPtr finalNoFree) --primNoFree
return (GUID p)
marshallGUID :: GUID -> IO (ForeignPtr GUID)
marshallGUID (GUID ptr) = return (castForeignPtr ptr)
{-
A version of the GUID marshaller which copies rather
than hands back a pointer to the (immutable) GUID.
-}
copyGUID :: GUID -> IO (Ptr ())
copyGUID (GUID ptr) = do
pg <- coAlloc sizeofGUID
primCopyGUID ptr pg
return pg
unmarshallGUID :: Bool -> Ptr GUID -> IO GUID
unmarshallGUID finaliseMe ptr = do
-- ToDo: verify that HDirect *never ever* allocates and
-- stores a GUID in malloc()-space, but consistently
-- uses the COM task allocator. (Why? because the
-- finalizer below will tell the COM task allocator
-- to free the GUID once done with it)
f <- makeFO ptr (castPtrToFunPtr $ if finaliseMe then finalFreeMemory else finalNoFree)
return (GUID f)
writeGUID :: Ptr GUID -> GUID -> IO ()
writeGUID ptr (GUID g) = poke (castPtr ptr) (foreignPtrToPtr g)
readGUID :: Bool -> Ptr GUID -> IO GUID
readGUID finaliseMe ptr = do
-- ptr <- peek ptr
unmarshallGUID finaliseMe ptr
sizeofGUID :: Word32
sizeofGUID = 16
stringToGUID :: String -> IO GUID
stringToGUID str =
stackWideString str $ \xstr -> do
pg <- coAlloc sizeofGUID
primStringToGUID xstr (castPtr pg)
unmarshallGUID True pg
stringFromGUID :: GUID -> IO String
stringFromGUID guid = do
pguid <- marshallGUID guid
pwide <- primGUIDToString (castForeignPtr pguid)
(pstr,hr) <- wideToString (castPtr pwide)
checkHR hr
str <- unmarshallString (castPtr pstr)
coFree pstr
coFree pwide
return str
guidToString :: GUID -> String
guidToString ptr = unsafePerformIO (stringFromGUID ptr)
{-
Give the interface identifier(IID) a type parameter, so that when
we come to define the Haskell type of <tt/IUnknown.QueryInterface(),/
we can use the type checker to ensure that the IID passed to
<tt/QueryInterface/ agrees with the interface at which we're using
the interface pointer that's returned (Hmm..this'll hopefully all become
clearer.)
-}
newtype IID a = IID GUID deriving ( Eq )
newtype CLSID = CLSID GUID deriving ( Eq )
mkIID :: String -> IID a
mkIID str = IID (mkGUID str)
mkCLSID :: String -> CLSID
mkCLSID str = CLSID (mkGUID str)
-- no need to provide marshallers for these, the IDL compiler
-- knows that they're both represented by GUIDs.
stringToIID :: String -> IID a
stringToIID str = mkIID str
stringToCLSID :: String -> CLSID
stringToCLSID str = mkCLSID str
iidToString :: IID a -> String
iidToString (IID i) = guidToString i
clsidToString :: CLSID -> String
clsidToString (CLSID clsid) = guidToString clsid
iidToGUID :: IID a -> GUID
iidToGUID (IID g) = g
castIID :: IID a -> IID b
castIID (IID i) = IID i
clsidToGUID :: CLSID -> GUID
clsidToGUID (CLSID g) = g
clsidToDisplayName :: CLSID -> String
clsidToDisplayName (CLSID g) = "clsid:" ++ tail (init (show g))
guidToIID :: GUID -> IID a
guidToIID g = IID g
guidToCLSID :: GUID -> CLSID
guidToCLSID g = CLSID g
instance Show (IID a) where
showsPrec _ (IID i) = showString (guidToString i)
instance Show CLSID where
showsPrec _ (CLSID c) = showString (guidToString c)
instance Show GUID where
showsPrec _ guid = showString (guidToString guid)
instance Eq GUID where
(GUID x) == (GUID y) = unsafePerformIO $ do
return (isEqualGUID x y)
marshallIID :: IID a -> IO (ForeignPtr (IID a))
marshallIID (IID x) = marshallGUID x >>= return.castForeignPtr
unmarshallIID :: Bool -> Ptr (IID a) -> IO (IID a)
unmarshallIID finaliseMe x = do
i <- unmarshallGUID finaliseMe (castPtr x)
return (IID i)
copyIID (IID x) = copyGUID x
readIID :: Bool -> Ptr (Ptr (IID a)) -> IO (IID a)
readIID finaliseMe ptr = do
a <- peek ptr
unmarshallIID finaliseMe (castPtr a)
writeIID :: Ptr (IID a) -> IID a -> IO ()
writeIID ptr (IID i) = writeGUID (castPtr ptr) i
--------
marshallCLSID (CLSID x) = marshallGUID x
unmarshallCLSID :: Bool -> Ptr CLSID -> IO CLSID
unmarshallCLSID finaliseMe x = do
i <- unmarshallGUID finaliseMe (castPtr x)
return (CLSID i)
copyCLSID (CLSID x) = copyGUID x
readCLSID :: Bool -> Ptr (Ptr CLSID) -> IO CLSID
readCLSID finaliseMe ptr = do
a <- peek ptr
unmarshallCLSID finaliseMe (castPtr a)
writeCLSID :: Ptr CLSID -> CLSID -> IO ()
writeCLSID ptr (CLSID i) = writeGUID (castPtr ptr) i
sizeofCLSID = sizeofGUID
coInitialize :: IO ()
coInitialize = comInitialize
coUnInitialize :: IO ()
coUnInitialize = comUnInitialize
sizeofIID = sizeofGUID
coEqual :: IUnknown a -> IUnknown b -> Bool
coEqual ip1 ip2 = unsafePerformIO $ primComEqual (castIface ip1) (castIface ip2)
--Interface pointer marshallers:
-- marshallIUnknown is in Base.idl
unmarshallIUnknown :: Bool -> Ptr b -> IO (IUnknown a)
unmarshallIUnknown finaliseMe x = do
ip <- addrToIPointer finaliseMe x
case finaliseMe of
True | x /= nullPtr -> ip # addRef >> return ip
_ -> return ip
unmarshallIUnknownFO :: ForeignPtr b -> IO (IUnknown a)
unmarshallIUnknownFO i = return (Unknown (castForeignPtr i))
-- ToDo: I believe it is correct never to do an AddRef()
-- here, but double-check the spec.
{-
addRefMe == True => attach finaliser (which calls Release()), and
call addRef on i-pointer before returning.
== False => attach finaliser (which calls Release()) only.
The former case is used when you receive an i-pointer from the outside
world and want to copy a reference to it into the Haskell heap. This
does not include i-pointers you receive via [out] pointers when calling
a COM component method from Haskell, where it is the obligation of the
server filling in the [out] pointer to call addRef() for you.
-}
readIUnknown :: Bool -> Ptr b -> IO (IUnknown a)
readIUnknown addRefMe x = do
ptr <- peek (castPtr x)
ip <- addrToIPointer True ptr
case addRefMe of
True | x /= nullPtr -> ip # addRef >> return ip
_ -> return ip
writeIUnknown :: Bool -> Ptr (Ptr (IUnknown b)) -> IUnknown a -> IO ()
writeIUnknown addRefMe x v = do
let a = ifaceToAddr v
when (addRefMe && a /= nullPtr)
(v # addRef >> return ())
writePtr x a
{-
@withObject@ applies every method in a list to an
object: @withObject genie [showUp, speak "hi", hide]@.
@withMethod@ applies every argument in a list to a
method: @genie # withMethod speak ["hello", "world"]@.
-}
withObject_ :: IUnknown a -> [IUnknown a -> IO b] -> IO ()
withObject_ obj = sequence_ . map ( obj # )
withMethod_ :: (a -> IUnknown b -> IO c) -> [a] -> IUnknown b -> IO ()
withMethod_ method args obj = sequence_ $ map (\x -> obj # method x) args
withObject :: IUnknown a -> [IUnknown a -> IO b] -> IO [b]
withObject obj = sequence . map ( obj # )
withMethod :: (a -> IUnknown b -> IO c) -> [a] -> IUnknown b -> IO [c]
withMethod method args obj = sequence $ map (\x -> obj # method x) args
loadTypeLib :: String -> IO (IUnknown a)
loadTypeLib fname = do
ptr <- allocOutPtr
stackWideString fname $ \pfname -> do
Base.loadTypeLib pfname ptr
doThenFree free (readIUnknown False{-finalise only-}) ptr
loadRegTypeLib :: GUID -> Int -> Int -> Int -> IO (IUnknown a)
loadRegTypeLib guid maj min lcid = do
ptr <- allocOutPtr
p_guid <- marshallGUID guid
Base.loadRegTypeLib (castForeignPtr p_guid)
(fromIntegral maj) (fromIntegral min)
(fromIntegral lcid) ptr
doThenFree free (readIUnknown False{-finalise only-}) ptr
queryPathOfRegTypeLib :: GUID
-> Word16
-> Word16
-> IO String
queryPathOfRegTypeLib gd maj min = do
pgd <- marshallGUID gd
pbstr <- primQueryPathOfRegTypeLib (castForeignPtr pgd) maj min
if nullPtr == pbstr then
return ""
else do
str <- unmarshallBSTR (castPtr pbstr)
freeBSTR pbstr
return str
createTypeLib :: String -> IO (IUnknown a) --(ICreateTypeLib a)
createTypeLib nm = do
wstr <- stringToWide nm
pptr <- primCreateTypeLib 1{-SYS_WIN32-} wstr
doThenFree free (readIUnknown False{-finalise only-}) pptr
loadTypeLibEx :: String -> Bool -> IO (IUnknown a)
loadTypeLibEx path reg_tlb = do
let
{-
This Int is used to map onto the following enum
typedef enum tagREGKIND { REGKIND_DEFAULT, REGKIND_REGISTER, REGKIND_NONE };
-}
rkind :: Int
rkind
| reg_tlb = 1
| otherwise = 2
out_ptr <- allocOutPtr
stackWideString path $ \pfname -> do
Base.loadTypeLibEx pfname (fromIntegral rkind) out_ptr
doThenFree free (readIUnknown False{-finalise only-}) out_ptr