----------------------------------------------------------------------------- -- | -- Module : System.Win32.Com.Automation -- Copyright : (c) Daan Leijen , Sigbjorn Finne 1998-99, Sigbjorn Finne 2000-2009 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : Sigbjorn Finne -- Stability : provisional -- Portability : portable -- -- Accessing COM / OLE Automation objects from Haskell clients. This library -- provides a fairly high-level view of Automation objects and the data values -- that their methods support. Transparent marshalling of arguments and invocation -- over Automation objects is supported via the 'Variant' class and a family -- of @invoke@ methods. This is also extended to cover the properties/fields of -- such 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 ) -- | @createObject progid@ is the Haskell equivalent of -- VB's @CreateObject@, trying to instantiate a new -- Automation object via an 'IDispatch' interfac pointer. createObject :: ProgID -> IO (IDispatch a) createObject progid = coCreateObject progid iidIDispatch_unsafe -- 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'. 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 either name or 'DISPID'. The latter saving you from having -- to do a method name resolution for each invocation. type Member = String -- type DISPID = Int sizeDISPID = 4 -- | @getMemberID memberName obj@ translates the @memberName@ string -- into the unique 'DISPID' representing that method/property. If unknown, -- a COM exception is raised. 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 the marshalling functions. Variants are represented as functions that can read or write a value from or to a variant structure. -} -- | @VarIn@ is the marshaller for 'Variant' arguments; a function that -- takes (a pointer to) a VARIANT structure and fills it in with value -- it encodes. type VarIn = VARIANT -> IO () -- | @VarRes@ is the unmarshaller for 'Variant results; a function that -- takes (a pointer to) the VARIANT result and unscrambles its contents -- into the Haskell value representing that 'Variant' result. type VarRes a = VARIANT -> IO a -- | @ArgIn@ is the extension of 'VarIn', returning a 'VarIn' marshaller -- for some 'Variant'-supported value of type @a@. type ArgIn a = a -> VarIn -- | @ArgRes@ is the 'Variant' unmarshaller for results of type @a@, where -- is one of the 'Variant' supported types. type ArgRes a = VarRes a -- | @ArgOut a@ represent an @in-out@ Automation parameter, pairing a marshaller -- with an unmarshaller for some type. Notice that the input value being marshalled -- may not have the same type as the output/result value being unmarshalled. type ArgOut a = (VarIn,ArgRes a) -- | @ArgInOut a b@ is the general 'in-out' parameter marshaller and result -- unmarshaller. 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