-----------------------------------------------------------------------------
-- |
-- Module      :  System.Win32.Com.Server.StdDispatch
-- Copyright   :  (c) Sigbjorn Finne <sof@dcs.gla.ac.uk> 1998-99
-- License     :  BSD-style (see the file libraries/base/LICENSE)
-- 
-- Maintainer  :  sof@forkIO.com
-- Stability   :  provisional
-- Portability :  portable
--
-- Implementation of IDispatch in Haskell; pretty useful
-- when creating\/registering dynamic, on-the-fly event
-- sinks.
-- 
-----------------------------------------------------------------------------
module System.Win32.Com.Server.StdDispatch
  ( createStdDispatchVTBL
        , createStdDispatchVTBL2
  
  , createStdDispatch

        , DispMethod(..)

  , inArg
  , inIUnknownArg
  , inoutArg
  , outArg
  , retVal

  , apply_0
  , apply_1
  , apply_2
  , apply_3
  , apply_4
  , apply_5
  , apply_6
  , apply_7

  , mkDispMethod
  , dispmethod_0_0
  , dispmethod_1_0
  , dispmethod_2_0
  , dispmethod_3_0

  , dispmethod_0_1
  , dispmethod_0_2

  ) where

import System.Win32.Com.Automation.TypeLib hiding (DISPID,invoke, getIDsOfNames)
import System.Win32.Com.Server
import System.Win32.Com
import System.Win32.Com.Automation
import System.Win32.Com.HDirect.HDirect

import Foreign.Ptr
import Foreign.Storable
import System.Win32.Com.Exception
import System.Win32.Com.HDirect.WideString
import Data.Bits
import System.IO.Unsafe
import Data.IORef ( newIORef, readIORef, writeIORef )
import Data.Int
import Data.List ( find )


createStdDispatch :: objState
      -> IO ()
                  -> [DispMethod objState]
      -> IID (IUnknown iid)
      -> IO (IUnknown iid)
createStdDispatch objState final meths iid = do
  vtbl <- createStdDispatchVTBL2 meths
  createComInstance "" objState final
                       [ mkIface iid vtbl
           , mkIface iidIDispatch vtbl
           ]
           iid

{-
This presents a simple, no-fuss implementation of a custom
IDispatch interface. It takes care of the minutiae of
implementing IDispatch, but leaves the programmer with the
task of specifying the instance specific bits of: mapping
from method names to DISPIDs + the invocation function which
performs the action associated with a particular DISPID,
including the marshaling and unmarshaling of VARIANT args.

Abstractions with varying degress of sophistication can be
layered on top of this basic IDispatch impl - see 
<tt/createStdDispatchVTBL2/ for one way of doing this.
-}

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]

{-
evDisp = 
{-
  simpleDisp mapDISPIDs
             invokeDISPIDs
-}
  simpleDisp2 
     [ dispmethod_0_0 "DownloadComplete" 1 onDownloadComplete
     , dispmethod_0_0 "DownloadBegin"    2 onDownloadBegin
     ]
 where
  mapDISPIDs x =
    case x of
    "DownloadComplete" -> Just 1
    "DownloadBegin"    -> Just 2
    "ProgressChange"   -> Just 3
    _                  -> Nothing

  invokeDISPIDs st d mk args =
    case d of
    1 -> st # onDownloadComplete
    2 -> st # onDownloadBegin
    3 -> st # onProgressChange
    _ -> return Nothing -- silently ignore.
-}
    
data DispMethod objState
  = DispMethod {
       disp_method_name :: String,     -- method name
       disp_method_id   :: DISPID,     -- its ...
       disp_method_kind :: MethodKind, -- bit of a misnomer.
       disp_method_act  :: ([VARIANT] -> objState -> IO (Maybe VARIANT))
    }

mkDispMethod :: String
             -> DISPID
       -> ([VARIANT] -> objState -> IO (Maybe VARIANT))
       -> DispMethod objState
mkDispMethod nm d f = DispMethod nm d Method f

dispmethod_0_0 :: String -> DISPID -> (objState -> IO ()) -> DispMethod objState
dispmethod_0_0 name id f 
  = DispMethod name id Method (apply_0 f)
dispmethod_1_0 name id f 
  = DispMethod name id Method (inArg $ \ x -> apply_0 (f x))
dispmethod_2_0 name id f 
  = DispMethod name id Method 
               (inArg $ \ x -> inArg $ \ y -> apply_0 (f x y))
dispmethod_3_0 name id f 
  = DispMethod name id Method 
               (inArg $ \ x -> inArg $ \ y -> inArg $ \ z -> apply_0 (f x y z))

dispmethod_0_1 name id f 
  = DispMethod name id Method
               (outArg $ \ ret_x -> apply_1 f ret_x)

dispmethod_0_2 name id f 
  = DispMethod name id Method
               (outArg $ \ ret_x -> outArg $ \ ret_y -> apply_2 f ret_x ret_y)

-- and so on..

createStdDispatchVTBL2 :: [DispMethod objState]
                       -> IO (ComVTable (IDispatch iid) objState)
createStdDispatchVTBL2 assoc = createStdDispatchVTBL lookup_dispid invoke_meths
 where
  lookup_dispid m_nm = 
    case (find ((==m_nm).disp_method_name) assoc) of
    Nothing      -> Nothing
    Just d       -> Just (disp_method_id d)

  invoke_meths did mkind args obj_st = 
     case (find ((==did).disp_method_id) assoc) of
     Nothing      -> return Nothing
     Just d       -> (disp_method_act d) args obj_st

{-
When using <tt/createStdDispatchVTBL2/, here's a couple
of helper functions to let you wrap up 

  HRESULT f([in]int i,[in,out]int* j,[out]int* pres, [out,retval]int* retval);

 as

   wrap_f = 
    inArg     $ \ i       ->
    inArg     $ \ j j_out ->
    resArg    $ \ pres    ->
    retVal    $ \ retval  ->
    apply_3 (f i j) j_out pres retval
-}
inArg :: ( Variant a )
      => (a -> [VARIANT] -> objState -> IO b)
      -> [VARIANT]
      -> objState
      -> IO b
inArg cont (a:args) objState = do
   x <- resVariant a
   cont x args objState

inIUnknownArg :: (IUnknown a -> [VARIANT] -> objState -> IO b)
              -> [VARIANT]
              -> objState
              -> IO b
inIUnknownArg cont (a:args) objState = do
   x <- resIUnknown a
   cont x args objState

inoutArg :: ( Variant a, Variant b )
         => ( a -> (b -> IO ()) -> [VARIANT] -> objState -> IO c)
         -> [VARIANT]
         -> objState
         -> IO c
inoutArg cont (a:args) objState = do
   x <- resVariant a
   cont x (\ x -> inVariant x a) args objState

outArg    :: ( Variant a )
    => ((a -> IO ()) -> [VARIANT] -> objState -> IO b)
          -> [VARIANT]
    -> objState
    -> IO b
outArg cont (a:args) objState = cont (\ x -> inVariant x a) args objState

retVal  :: ( Variant a )
        => ((a -> IO ()) -> [VARIANT] -> objState -> IO (Maybe VARIANT))
  -> [VARIANT]
  -> objState
  -> IO (Maybe VARIANT)
retVal cont args objState = do
   -- what a hack.
  res_ref <- newIORef Nothing
  cont (\ x -> writeIORef res_ref (Just x)) args objState 
  retv <- readIORef res_ref
  case retv of
    Nothing -> return Nothing
    Just x  -> do
      pVarResult <- allocBytes (fromIntegral sizeofVARIANT)
      inVariant x pVarResult
      return (Just pVarResult)

apply_0 :: (objState -> IO ())
        -> [VARIANT]
        -> objState
        -> IO (Maybe VARIANT)
apply_0 f _ objState = f objState >> return Nothing

apply_1 :: (Variant a)
        => (objState -> IO a)
  -> (a -> IO ())
        -> [VARIANT]
  -> objState
  -> IO (Maybe VARIANT)
apply_1 f res_1 _ objState = do
   x <- f objState
   res_1 x
   return Nothing

apply_2 :: (Variant a0, Variant a1)
        => (objState -> IO (a0,a1))
  -> (a0 -> IO ())
  -> (a1 -> IO ())
        -> [VARIANT]
  -> objState
  -> IO (Maybe VARIANT)
apply_2 f res_1 res_2 _ objState = do
   (x,y) <- f objState
   res_1 x
   res_2 y
   return Nothing

apply_3 :: (Variant a0, Variant a1, Variant a2)
        => (objState -> IO (a0,a1,a2))
  -> (a0 -> IO ())
  -> (a1 -> IO ())
  -> (a2 -> IO ())
        -> [VARIANT]
  -> objState
  -> IO (Maybe VARIANT)
apply_3 f res_1 res_2 res_3 _ objState = do
   (a0,a1,a2) <- f objState
   res_1 a0
   res_2 a1
   res_3 a2
   return Nothing

apply_4 :: (Variant a0, Variant a1, Variant a2, Variant a3)
        => (objState -> IO (a0,a1,a2,a3))
  -> (a0 -> IO ())
  -> (a1 -> IO ())
  -> (a2 -> IO ())
  -> (a3 -> IO ())
        -> [VARIANT]
  -> objState
  -> IO (Maybe VARIANT)
apply_4 f res_1 res_2 res_3 res_4 _ objState = do
   (a0,a1,a2,a3) <- f objState
   res_1 a0
   res_2 a1
   res_3 a2
   res_4 a3
   return Nothing

apply_5 :: (Variant a0, Variant a1, Variant a2, Variant a3, Variant a4)
        => (objState -> IO (a0,a1,a2,a3,a4))
  -> (a0 -> IO ())
  -> (a1 -> IO ())
  -> (a2 -> IO ())
  -> (a3 -> IO ())
  -> (a4 -> IO ())
        -> [VARIANT]
  -> objState
  -> IO (Maybe VARIANT)
apply_5 f res_1 res_2 res_3 res_4 res_5 _ objState = do
   (a0,a1,a2,a3,a4) <- f objState
   res_1 a0
   res_2 a1
   res_3 a2
   res_4 a3
   res_5 a4
   return Nothing

apply_6 :: (Variant a0, Variant a1, Variant a2, Variant a3, Variant a4, Variant a5)
        => (objState -> IO (a0,a1,a2,a3,a4,a5))
  -> (a0 -> IO ())
  -> (a1 -> IO ())
  -> (a2 -> IO ())
  -> (a3 -> IO ())
  -> (a4 -> IO ())
  -> (a5 -> IO ())
        -> [VARIANT]
  -> objState
  -> IO (Maybe VARIANT)
apply_6 f res_1 res_2 res_3 res_4 res_5 res_6 _ objState = do
   (a0,a1,a2,a3,a4,a5) <- f objState
   res_1 a0
   res_2 a1
   res_3 a2
   res_4 a3
   res_5 a4
   res_6 a5
   return Nothing

apply_7 :: (Variant a0, Variant a1, Variant a2, Variant a3, Variant a4, Variant a5, Variant a6)
        => (objState -> IO (a0,a1,a2,a3,a4,a5,a6))
  -> (a0 -> IO ())
  -> (a1 -> IO ())
  -> (a2 -> IO ())
  -> (a3 -> IO ())
  -> (a4 -> IO ())
  -> (a5 -> IO ())
  -> (a6 -> IO ())
        -> [VARIANT]
  -> objState
  -> IO (Maybe VARIANT)
apply_7 f res_1 res_2 res_3 res_4 res_5 res_6 res_7 _ objState = do
   (a0,a1,a2,a3,a4,a5,a6) <- f objState
   res_1 a0
   res_2 a1
   res_3 a2
   res_4 a3
   res_5 a4
   res_6 a5
   res_7 a6
   return Nothing

type ThisPtr a = Ptr a

invoke :: (DISPID -> MethodKind -> [VARIANT] -> objState -> IO (Maybe VARIANT))
       -> Ptr (IDispatch ())
       -> DISPID
       -> Ptr (IID ())
       -> LCID
       -> Word32
       -> Ptr (Ptr ()) --DISPPARAMS
       -> Ptr VARIANT
       -> Ptr (Ptr ()) --EXCEPINFO
       -> Ptr Word32
       -> IO HRESULT
invoke dispMeth this dispIdMember riid lcid wFlags pDispParams
       pVarResult pExcepInfo puArgErr = do
   iid <- unmarshallIID False riid
   if (iid /= iidNULL) then
      return dISP_E_UNKNOWNINTERFACE
    else do
      let mkind = toMethodKind wFlags
          args  = unsafePerformIO (unmarshallArgs (castPtr pDispParams))
      st  <- getObjState this
      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
--              putMessage ("Invoke: " ++ show dispIdMember ++ " interested")
                writeVARIANT pVarResult x
          return s_OK) 
       (\ err -> 
          case coGetErrorHR err of
            Nothing -> do
              if pExcepInfo == nullPtr then
                return dISP_E_EXCEPTION
               else do
                poke (castPtr pExcepInfo) nullPtr
                return dISP_E_EXCEPTION
            Just hr ->
              -- ToDo: a lot better.
              if pExcepInfo == nullPtr then
                return hr
               else do
                poke (castPtr pExcepInfo) nullPtr
                return hr)
        

unmarshallArgs :: Ptr DISPPARAMS -> IO [VARIANT]
unmarshallArgs ptr 
  | ptr == nullPtr = return []
  | otherwise       = do
     dp <- readDISPPARAMS (castPtr ptr)
     case dp of
       (TagDISPPARAMS rs _) -> return rs


data MethodKind = Method | PropertyGet | PropertyPut

toMethodKind :: Word32 -> MethodKind
toMethodKind x
  | x .&. dISPATCH_METHOD         /= 0 = Method
  | x .&. dISPATCH_PROPERTYGET    /= 0 = PropertyGet
  | x .&. dISPATCH_PROPERTYPUT    /= 0 = PropertyPut
  | x .&. dISPATCH_PROPERTYPUTREF /= 0 = PropertyPut
  | otherwise             = Method

dISPATCH_METHOD :: Word32
dISPATCH_METHOD = 0x1
dISPATCH_PROPERTYGET :: Word32
dISPATCH_PROPERTYGET = 0x2
dISPATCH_PROPERTYPUT :: Word32
dISPATCH_PROPERTYPUT = 0x4
dISPATCH_PROPERTYPUTREF :: Word32
dISPATCH_PROPERTYPUTREF = 0x8

getIDsOfNames :: (String -> Maybe DISPID)
        -> ThisPtr (IDispatch ())
        -> Ptr (IID ())
        -> Ptr WideString
        -> Word32
        -> LCID
        -> Ptr DISPID
        -> IO HRESULT
getIDsOfNames lookup_dispid this riid rgszNames cNames lcid rgDispID
  | cNames /= 1 = return e_FAIL
  | otherwise   = do
      pwide     <- peek (castPtr rgszNames)
      (pstr,hr) <- wideToString pwide
      checkHR hr
      str       <- unmarshallString (castPtr pstr)
      case lookup_dispid str of
        Nothing -> return e_FAIL
        Just v  -> do
          writeInt32 rgDispID v
          return s_OK

{-
We don't expose type information of any sort, so 
here's the negative versions of the two IDispatch
methods.
-}

getTypeInfoCount_none :: Ptr () -> Ptr Word32 -> IO HRESULT
getTypeInfoCount_none iptr pctInfo = do
  writeWord32 pctInfo 0
  return s_OK

getTypeInfo_none :: Ptr (IDispatch ()) -> Word32 -> LCID -> Ptr () -> IO HRESULT
getTypeInfo_none this iTInfo lcid ppTInfo
  | iTInfo /= 0         = return tYPE_E_ELEMENTNOTFOUND
  | ppTInfo == nullPtr = return e_POINTER
  | otherwise    = do
     poke (castPtr ppTInfo) nullPtr
     return s_OK