module System.Win32.Com.Server.StdDispatch
( createStdDispatchVTBL
, createStdDispatchVTBL2
, createStdDispatch
, DispMethod(..)
, inArg
, inIUnknownArg
, inoutArg
, outArg
, retVal
, apply_0
, apply_1
, apply_2
, apply_3
, apply_4
, apply_5
, apply_6
, apply_7
, mkDispMethod
, dispmethod_0_0
, dispmethod_1_0
, dispmethod_2_0
, dispmethod_3_0
, dispmethod_0_1
, dispmethod_0_2
) where
import System.Win32.Com.Automation.TypeLib hiding (DISPID,invoke, getIDsOfNames)
import System.Win32.Com.Server
import System.Win32.Com
import System.Win32.Com.Automation
import System.Win32.Com.HDirect.HDirect
import Foreign.Ptr
import Foreign.Storable
import System.Win32.Com.Exception
import System.Win32.Com.HDirect.WideString
import Data.Bits
import System.IO.Unsafe
import Data.IORef ( newIORef, readIORef, writeIORef )
import Data.Int
import Data.List ( find )
createStdDispatch :: objState
-> IO ()
-> [DispMethod objState]
-> IID (IUnknown iid)
-> IO (IUnknown iid)
createStdDispatch objState final meths iid = do
vtbl <- createStdDispatchVTBL2 meths
createComInstance "" objState final
[ mkIface iid vtbl
, mkIface iidIDispatch vtbl
]
iid
createStdDispatchVTBL :: (String -> Maybe DISPID)
-> (DISPID -> MethodKind -> [VARIANT] -> objState -> IO (Maybe VARIANT))
-> IO (ComVTable (IDispatch iid) objState)
createStdDispatchVTBL meths fun = do
a_getTypeInfoCount <- export_getTypeInfoCount getTypeInfoCount_none
a_getTypeInfo <- export_getTypeInfo getTypeInfo_none
a_getIDsOfNames <- export_getIDsOfNames (getIDsOfNames meths)
a_invoke <- export_invoke (invoke fun)
createComVTable
[castPtr a_getTypeInfoCount, castPtr a_getTypeInfo, castPtr a_getIDsOfNames, castPtr a_invoke]
data DispMethod objState
= DispMethod {
disp_method_name :: String,
disp_method_id :: DISPID,
disp_method_kind :: MethodKind,
disp_method_act :: ([VARIANT] -> objState -> IO (Maybe VARIANT))
}
mkDispMethod :: String
-> DISPID
-> ([VARIANT] -> objState -> IO (Maybe VARIANT))
-> DispMethod objState
mkDispMethod nm d f = DispMethod nm d Method f
dispmethod_0_0 :: String -> DISPID -> (objState -> IO ()) -> DispMethod objState
dispmethod_0_0 name id f
= DispMethod name id Method (apply_0 f)
dispmethod_1_0 name id f
= DispMethod name id Method (inArg $ \ x -> apply_0 (f x))
dispmethod_2_0 name id f
= DispMethod name id Method
(inArg $ \ x -> inArg $ \ y -> apply_0 (f x y))
dispmethod_3_0 name id f
= DispMethod name id Method
(inArg $ \ x -> inArg $ \ y -> inArg $ \ z -> apply_0 (f x y z))
dispmethod_0_1 name id f
= DispMethod name id Method
(outArg $ \ ret_x -> apply_1 f ret_x)
dispmethod_0_2 name id f
= DispMethod name id Method
(outArg $ \ ret_x -> outArg $ \ ret_y -> apply_2 f ret_x ret_y)
createStdDispatchVTBL2 :: [DispMethod objState]
-> IO (ComVTable (IDispatch iid) objState)
createStdDispatchVTBL2 assoc = createStdDispatchVTBL lookup_dispid invoke_meths
where
lookup_dispid m_nm =
case (find ((==m_nm).disp_method_name) assoc) of
Nothing -> Nothing
Just d -> Just (disp_method_id d)
invoke_meths did mkind args obj_st =
case (find ((==did).disp_method_id) assoc) of
Nothing -> return Nothing
Just d -> (disp_method_act d) args obj_st
inArg :: ( Variant a )
=> (a -> [VARIANT] -> objState -> IO b)
-> [VARIANT]
-> objState
-> IO b
inArg cont (a:args) objState = do
x <- resVariant a
cont x args objState
inIUnknownArg :: (IUnknown a -> [VARIANT] -> objState -> IO b)
-> [VARIANT]
-> objState
-> IO b
inIUnknownArg cont (a:args) objState = do
x <- resIUnknown a
cont x args objState
inoutArg :: ( Variant a, Variant b )
=> ( a -> (b -> IO ()) -> [VARIANT] -> objState -> IO c)
-> [VARIANT]
-> objState
-> IO c
inoutArg cont (a:args) objState = do
x <- resVariant a
cont x (\ x -> inVariant x a) args objState
outArg :: ( Variant a )
=> ((a -> IO ()) -> [VARIANT] -> objState -> IO b)
-> [VARIANT]
-> objState
-> IO b
outArg cont (a:args) objState = cont (\ x -> inVariant x a) args objState
retVal :: ( Variant a )
=> ((a -> IO ()) -> [VARIANT] -> objState -> IO (Maybe VARIANT))
-> [VARIANT]
-> objState
-> IO (Maybe VARIANT)
retVal cont args objState = do
res_ref <- newIORef Nothing
cont (\ x -> writeIORef res_ref (Just x)) args objState
retv <- readIORef res_ref
case retv of
Nothing -> return Nothing
Just x -> do
pVarResult <- allocBytes (fromIntegral sizeofVARIANT)
inVariant x pVarResult
return (Just pVarResult)
apply_0 :: (objState -> IO ())
-> [VARIANT]
-> objState
-> IO (Maybe VARIANT)
apply_0 f _ objState = f objState >> return Nothing
apply_1 :: (Variant a)
=> (objState -> IO a)
-> (a -> IO ())
-> [VARIANT]
-> objState
-> IO (Maybe VARIANT)
apply_1 f res_1 _ objState = do
x <- f objState
res_1 x
return Nothing
apply_2 :: (Variant a0, Variant a1)
=> (objState -> IO (a0,a1))
-> (a0 -> IO ())
-> (a1 -> IO ())
-> [VARIANT]
-> objState
-> IO (Maybe VARIANT)
apply_2 f res_1 res_2 _ objState = do
(x,y) <- f objState
res_1 x
res_2 y
return Nothing
apply_3 :: (Variant a0, Variant a1, Variant a2)
=> (objState -> IO (a0,a1,a2))
-> (a0 -> IO ())
-> (a1 -> IO ())
-> (a2 -> IO ())
-> [VARIANT]
-> objState
-> IO (Maybe VARIANT)
apply_3 f res_1 res_2 res_3 _ objState = do
(a0,a1,a2) <- f objState
res_1 a0
res_2 a1
res_3 a2
return Nothing
apply_4 :: (Variant a0, Variant a1, Variant a2, Variant a3)
=> (objState -> IO (a0,a1,a2,a3))
-> (a0 -> IO ())
-> (a1 -> IO ())
-> (a2 -> IO ())
-> (a3 -> IO ())
-> [VARIANT]
-> objState
-> IO (Maybe VARIANT)
apply_4 f res_1 res_2 res_3 res_4 _ objState = do
(a0,a1,a2,a3) <- f objState
res_1 a0
res_2 a1
res_3 a2
res_4 a3
return Nothing
apply_5 :: (Variant a0, Variant a1, Variant a2, Variant a3, Variant a4)
=> (objState -> IO (a0,a1,a2,a3,a4))
-> (a0 -> IO ())
-> (a1 -> IO ())
-> (a2 -> IO ())
-> (a3 -> IO ())
-> (a4 -> IO ())
-> [VARIANT]
-> objState
-> IO (Maybe VARIANT)
apply_5 f res_1 res_2 res_3 res_4 res_5 _ objState = do
(a0,a1,a2,a3,a4) <- f objState
res_1 a0
res_2 a1
res_3 a2
res_4 a3
res_5 a4
return Nothing
apply_6 :: (Variant a0, Variant a1, Variant a2, Variant a3, Variant a4, Variant a5)
=> (objState -> IO (a0,a1,a2,a3,a4,a5))
-> (a0 -> IO ())
-> (a1 -> IO ())
-> (a2 -> IO ())
-> (a3 -> IO ())
-> (a4 -> IO ())
-> (a5 -> IO ())
-> [VARIANT]
-> objState
-> IO (Maybe VARIANT)
apply_6 f res_1 res_2 res_3 res_4 res_5 res_6 _ objState = do
(a0,a1,a2,a3,a4,a5) <- f objState
res_1 a0
res_2 a1
res_3 a2
res_4 a3
res_5 a4
res_6 a5
return Nothing
apply_7 :: (Variant a0, Variant a1, Variant a2, Variant a3, Variant a4, Variant a5, Variant a6)
=> (objState -> IO (a0,a1,a2,a3,a4,a5,a6))
-> (a0 -> IO ())
-> (a1 -> IO ())
-> (a2 -> IO ())
-> (a3 -> IO ())
-> (a4 -> IO ())
-> (a5 -> IO ())
-> (a6 -> IO ())
-> [VARIANT]
-> objState
-> IO (Maybe VARIANT)
apply_7 f res_1 res_2 res_3 res_4 res_5 res_6 res_7 _ objState = do
(a0,a1,a2,a3,a4,a5,a6) <- f objState
res_1 a0
res_2 a1
res_3 a2
res_4 a3
res_5 a4
res_6 a5
res_7 a6
return Nothing
type ThisPtr a = Ptr a
invoke :: (DISPID -> MethodKind -> [VARIANT] -> objState -> IO (Maybe VARIANT))
-> Ptr (IDispatch ())
-> DISPID
-> Ptr (IID ())
-> LCID
-> Word32
-> Ptr (Ptr ()) --DISPPARAMS
-> Ptr VARIANT
-> Ptr (Ptr ()) --EXCEPINFO
-> Ptr Word32
-> IO HRESULT
invoke dispMeth this dispIdMember riid lcid wFlags pDispParams
pVarResult pExcepInfo puArgErr = do
iid <- unmarshallIID False riid
if (iid /= iidNULL) then
return dISP_E_UNKNOWNINTERFACE
else do
let mkind = toMethodKind wFlags
args = unsafePerformIO (unmarshallArgs (castPtr pDispParams))
st <- getObjState this
catchComException (do
res <- dispMeth dispIdMember mkind args st
case res of
Nothing -> do
if pVarResult == nullPtr then
return ()
else
poke pVarResult nullPtr
Just x -> do
writeVARIANT pVarResult x
return s_OK)
(\ err ->
case coGetErrorHR err of
Nothing -> do
if pExcepInfo == nullPtr then
return dISP_E_EXCEPTION
else do
poke (castPtr pExcepInfo) nullPtr
return dISP_E_EXCEPTION
Just hr ->
if pExcepInfo == nullPtr then
return hr
else do
poke (castPtr pExcepInfo) nullPtr
return hr)
unmarshallArgs :: Ptr DISPPARAMS -> IO [VARIANT]
unmarshallArgs ptr
| ptr == nullPtr = return []
| otherwise = do
dp <- readDISPPARAMS (castPtr ptr)
case dp of
(TagDISPPARAMS rs _) -> return rs
data MethodKind = Method | PropertyGet | PropertyPut
toMethodKind :: Word32 -> MethodKind
toMethodKind x
| x .&. dISPATCH_METHOD /= 0 = Method
| x .&. dISPATCH_PROPERTYGET /= 0 = PropertyGet
| x .&. dISPATCH_PROPERTYPUT /= 0 = PropertyPut
| x .&. dISPATCH_PROPERTYPUTREF /= 0 = PropertyPut
| otherwise = Method
dISPATCH_METHOD :: Word32
dISPATCH_METHOD = 0x1
dISPATCH_PROPERTYGET :: Word32
dISPATCH_PROPERTYGET = 0x2
dISPATCH_PROPERTYPUT :: Word32
dISPATCH_PROPERTYPUT = 0x4
dISPATCH_PROPERTYPUTREF :: Word32
dISPATCH_PROPERTYPUTREF = 0x8
getIDsOfNames :: (String -> Maybe DISPID)
-> ThisPtr (IDispatch ())
-> Ptr (IID ())
-> Ptr WideString
-> Word32
-> LCID
-> Ptr DISPID
-> IO HRESULT
getIDsOfNames lookup_dispid this riid rgszNames cNames lcid rgDispID
| cNames /= 1 = return e_FAIL
| otherwise = do
pwide <- peek (castPtr rgszNames)
(pstr,hr) <- wideToString pwide
checkHR hr
str <- unmarshallString (castPtr pstr)
case lookup_dispid str of
Nothing -> return e_FAIL
Just v -> do
writeInt32 rgDispID v
return s_OK
getTypeInfoCount_none :: Ptr () -> Ptr Word32 -> IO HRESULT
getTypeInfoCount_none iptr pctInfo = do
writeWord32 pctInfo 0
return s_OK
getTypeInfo_none :: Ptr (IDispatch ()) -> Word32 -> LCID -> Ptr () -> IO HRESULT
getTypeInfo_none this iTInfo lcid ppTInfo
| iTInfo /= 0 = return tYPE_E_ELEMENTNOTFOUND
| ppTInfo == nullPtr = return e_POINTER
| otherwise = do
poke (castPtr ppTInfo) nullPtr
return s_OK