com-1.2.2: System/Win32/Com/Automation.hs
{-# OPTIONS -#include "autoPrim.h" #-}
-----------------------------------------------------------------------------
-- |
-- Module : System.Win32.Com.Automation
-- Copyright : (c) Daan Leijen <leijen@fwi.uva.nl>, Sigbjorn Finne <sof@dcs.gla.ac.uk> 1998-99, Sigbjorn Finne <sigbjorn.finne@gmail.com> 2000-2009
-- License : BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer : Sigbjorn Finne <sigbjorn.finne@gmail.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,
marshallCurrency, unmarshallCurrency,
readCurrency, writeCurrency,
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 System.IO.Error ( ioeGetErrorString )
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
import System.IO ( hPutStrLn, stderr )
{-
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 `catchComException` (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
instance Variant Int64 where
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
instance Variant Word64 where
inVariant = inWord64
resVariant = resWord64
defaultVariant = defaultWord64
vtEltType _ = VT_DECIMAL -- since VT_UI8 isn't supported in VARIANTs.
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 =
catchComException
(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
defaultInt64 :: Int64
defaultInt64 = 0
inInt64 :: ArgIn Int64
inInt64 i = inWord64 (fromIntegral i)
resInt64 :: ArgRes Int64
resInt64 p = resWord64 p >>= return.fromIntegral
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
defaultWord64 :: Word64
defaultWord64 = 0
inWord64 :: ArgIn Word64
inWord64 f =
let
(hi,lo) = toInteger f `divMod` (toInteger (maxBound :: Int) + 1)
in
writeVarWord64 (fromInteger hi) (fromInteger lo)
resWord64 :: ArgRes Word64
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 (fromEnum i))
resChar :: ArgRes Char
resChar p = readVarByte p >>= \ x -> return (toEnum (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
= Int64
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
(hi,lo) = f `divMod` (fromIntegral (maxBound :: Int) + 1)
in
writeVarCurrency (fromIntegral (fromIntegral hi)) (fromIntegral (fromIntegral lo))
-- NOTE: this handles the decimal currency type in a shallow way, i.e., in its
-- int64-encoded form. To translate that fixed-point number (15,4) encoding
-- you'll have to do some more work...
resCurrency :: ArgRes Currency
resCurrency v = do
(hi,lo) <- readVarCurrency v
return (coerceI (fromIntegral hi) * (coerceI (maxBound :: Int) + 1) +
coerceI (fromIntegral lo))
where
coerceI = fromIntegral
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 "String" 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 "IUnknown" 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 "IDispatch" 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 -> Either IOError ComException -> IO a
errorMember member err
= coFail ("method '" ++ member ++ "': " ++ (coGetErrorString err))
catchMethError :: Member -> IO a -> IO a
catchMethError member act = catchComException 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 :: String
-> (VARIANT -> IO (Ptr (Ptr b), Ptr (VARIANT)))
-> VARIANT
-> (Ptr b -> IO d)
-> IO d
readTempVar atTy io p f = do
tg <- readVariantTag p
(x,v) <-
catchComException (io p)
(\ ex -> do
hPutStrLn stderr ("VARIANT error: found type " ++ show (tg, atTy))
throwIOComException ex)
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 <-
catchComException (ip # propertyGet "_NewEnum" [] outIUnknown)
(\ _ -> ip # function1 "_NewEnum" [] outIUnknown)
ienum <- iunk # queryInterface iidIEnumVARIANT
len <-
catchComException (ip # propertyGet "length" [] outInt)
(\ _ -> ip # propertyGet "Count" [] outInt)
return (len, castIface ienum)
enumVariants :: Variant a => IDispatch b -> IO (Int, [a])
enumVariants ip = do
(len, ienum) <- newEnum ip
-- enumNext (fromIntegral sizeofVARIANT) resVariant (fromIntegral len) ienum
let
getByOne ie = do
mb <- ie # enumNextOne (fromIntegral sizeofVARIANT) resVariant
case mb of
Nothing -> return []
Just x -> do
-- note: here we have the option of making it on-demand..
xs <- getByOne ie
return (x:xs)
ls <- getByOne ienum
return (len, ls)
--Helpers
always :: IO a -> IO () -> IO a
always io action = do
x <- io `catchComException` (\ e -> action >> throwIOComException e)
action
return x
marshallCurrency = marshallInt64
unmarshallCurrency = unmarshallInt64
readCurrency = readInt64
writeCurrency = writeInt64
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