-----------------------------------------------------------------------------
-- |
-- Module      :  System.Win32.Com
-- Copyright   :  (c) Sigbjorn Finne, sof@dcs.gla.ac.uk 1999
-- License     :  BSD-style (see the file libraries/base/LICENSE)
-- 
-- Maintainer  :  sof@forkIO.com
-- Stability   :  provisional
-- Portability :  portable
--
-- Support library for interacting with base Microsoft COM services and API.
-- 
-----------------------------------------------------------------------------
module System.Win32.Com
    (
      -- base COM interface, IUnknown:
      IUnknown_   -- abstract, instance of: Eq, Show.
    , IUnknown    
    , iidIUnknown  -- :: IID (IUnknown ())
    
    , interfaceNULL, isNullInterface, iidNULL

      -- its methods:
    , queryInterface -- :: IID (IUnknown b) -> IUnknown a -> IO (IUnknown b)
    , addRef -- :: IUnknown a -> IO Word32
    , release     -- :: IUnknown a -> IO Word32
    , withQueryInterface -- :: IID (IUnknown b) -> IUnknown a -> (IUnknown b -> IO c) -> IO c

      -- helpful operators:
    , ( # )    -- :: a -> (a -> IO b) -> IO b
    , ( ## )    -- :: IO a -> (a -> IO b) -> IO b


      -- setting up and shutting down.
    , coRun      -- :: IO a -> IO a
    , coPerformIO         -- :: IO a -> IO a
    , coUnsafePerformIO   -- :: IO a -> a
    , coInitialize    -- :: IO ()
    , coUnInitialize    -- :: IO ()
    
      -- GUID API:
    , GUID    -- abstract, instance of: Eq, Show
    , mkGUID    -- :: String -> GUID
    , newGUID           -- :: IO GUID
    , stringToGUID  -- :: String -> IO GUID
    , guidToString  -- :: GUID   -> String
    , nullGUID    -- :: GUID

      -- IID API:
    , IID    -- abstract, instance of: Eq, Show
    , mkIID    -- :: String -> IID a
    , stringToIID  -- :: String -> IO (IID a)
    , guidToIID    -- :: GUID   -> IID a
    , iidToGUID    -- :: IID a  -> GUID
    , castIID           -- :: IID a  -> IID b

      -- CLSID API:
    , CLSID     -- abstract, instance of: Eq, Show
    , mkCLSID     -- :: String -> CLSID
    , stringToCLSID   -- :: String -> IO CLSID
    , guidToCLSID   -- :: GUID   -> CLSID
    , clsidToGUID   -- :: CLSID  -> GUID
    , clsidToDisplayName -- :: CLSID  -> String

      -- LIBID
    , LIBID    -- (a guid)
    , mkLIBID           -- :: String -> LIBID

      -- HRESULT API:
    , HRESULT
    , s_FALSE    -- :: HRESULT
    , s_OK    -- :: HRESULT
    , succeeded          -- :: HRESULT -> Bool
    , failed          -- :: HRESULT -> Bool
    , checkHR    -- :: HRESULT -> IO ()
    , checkBool    -- :: Int32   -> IO ()
    , returnHR    -- :: IO ()   -> IO HRESULT
    , coFailHR    -- :: HRESULT -> IO a
    , coFailWithHR  -- :: HRESULT -> String  -> IO 
    , coAssert    -- :: Bool    -> String -> IO ()
    , coOnFail    -- :: IO a    -> String -> IO a
    , coFail    -- :: String  -> IO a
    , isCoError    -- :: IOError -> Bool
    , coGetErrorHR      -- :: IOError -> HRESULT
    , coGetErrorString  -- :: IOError -> String
    , hresultToString   -- :: HRESULT -> IO String
    
    , ComException(..)
    , catchComException
    , throwIOComException
    , throwComException

      -- component creation:
    , coCreateInstance -- :: CLSID -> Maybe (IUnknown b) -> CLSCTX
           -- -> IID (IUnknown a) -> IO (IUnknown a)
    , coCreateObject
    , coGetObject
    , coGetActiveObject
    , coGetFileObject
    , coCreateInstanceEx
    , COSERVERINFO(..)
    , COAUTHIDENTITY(..)
    , COAUTHINFO(..)

    , withObject   -- :: IUnknown a -> [IUnknown a -> IO b] -> IO [b]
    , withObject_  -- :: IUnknown a -> [IUnknown a -> IO b] -> IO ()
    , withMethod   -- :: (a -> IUnknown b -> IO c) -> [a] -> IUnknown b -> IO [c]
    , withMethod_  -- :: (a -> IUnknown b -> IO c) -> [a] -> IUnknown b -> IO ()


    , CLSCTX(..)

    , ProgID
    , progIDFromCLSID     -- :: CLSID  -> IO ProgID
    , clsidFromProgID     -- :: ProgID -> IO CLSID

    , printMessage
    , putMessage
    , messageBox
    , outputDebugString

    , OSVersionInfo(..)
    , isWindowsNT          -- :: OSVersionInfo -> Bool
    , isWindows95          -- :: OSVersionInfo -> Bool
    , isWindows98          -- :: OSVersionInfo -> Bool
    , versionInfo     -- :: OSVersionInfo

    , ifaceToAddr
    
      -- IEnum* methods.
    , enumNext
    , enumNextOne
    , enumClone
    , enumReset
    , enumSkip
    
    , BSTR
    , marshallBSTR
    , unmarshallBSTR
    , readBSTR
    , writeBSTR
    , freeBSTR
    , LPSTR
    
    , coFree
    , coAlloc
    
    , marshallIUnknown
    , unmarshallIUnknown
    , readIUnknown
    , writeIUnknown
    
    , unmarshallIUnknownFO
    , castIface
    
      -- Re-export WideStrings
    , WideString
    , marshallWideString
    , unmarshallWideString
    , writeWideString
    , readWideString
    , sizeofWideString
    , freeWideString
    
      -- marshallers
    , marshallGUID  -- :: GUID -> IO (ForeignPtr GUID)
    , unmarshallGUID  -- :: Bool -> Ptr GUID -> IO GUID
    , writeGUID
    , readGUID
    , copyGUID
    , sizeofGUID
    
      -- marshallers
    , marshallIID  -- :: GUID -> IO (ForeignPtr GUID)
    , unmarshallIID  -- :: Bool -> Ptr GUID -> IO GUID
    , writeIID
    , readIID
    , sizeofIID
    , copyIID
    
      -- marshallers
    , marshallCLSID  -- :: CLSID -> IO (ForeignPtr CLSID)
    , unmarshallCLSID  -- :: Bool -> Ptr CLSID -> IO GUID
    , writeCLSID
    , readCLSID
    , sizeofCLSID
    , copyCLSID
    
    , invokeAndCheck
    , invokeIt
    
    , loadTypeLib
    , loadTypeLibEx
    , loadRegTypeLib
    , queryPathOfRegTypeLib
    , createTypeLib
    
    , LCID
    
    , messagePump
    , postQuitMsg
    
    ) where


import System.Win32.Com.Exception
import System.Win32.Com.Base 
         hiding ( coCreateInstance, loadTypeLib, messageBox,
      loadTypeLibEx, loadRegTypeLib, coCreateInstanceEx
          )
import qualified System.Win32.Com.Base as Base
          ( coCreateInstance, loadTypeLib, messageBox,
         loadTypeLibEx, loadRegTypeLib, coCreateInstanceEx
          )
import System.Win32.Com.HDirect.HDirect
import System.Win32.Com.HDirect.Pointer hiding ( freeBSTR )
import qualified System.Win32.Com.HDirect.Pointer as P ( freeBSTR )
import System.Win32.Com.HDirect.WideString
import System.IO.Unsafe  ( unsafePerformIO )
import Control.Monad     ( when )
import Foreign.StablePtr ( deRefStablePtr )
import Foreign.Ptr
import Foreign.ForeignPtr
import Foreign.Storable
import Foreign.Marshal.Alloc ( allocaBytes )
import Data.Bits
import Control.Exception ( bracket ) 

infixl 1 #
infixl 0 ##

--Operators to provide OO-looking invocation of interface methods, e.g., 
--
--   ip # meth1 args

-- | The @#@ operator permits /OO-style/ method application with @do@ syntax:
--
-- @
--  obj # method arg1 arg2
-- @
--
-- is equivalent to @method arg1 arg2 obj@, so this assumes that the COM method 
-- wrappers takes the /this/ pointer as the last argument. Which the /HDirect/
-- generated wrappers do and the various base method provided by this COM+Automation library.
( # )  :: a -> (a -> IO b) -> IO b
obj # method          = method obj

-- | A variation on @(#)@ where the /this/ pointer is an action returning an object reference
-- rather than the reference itself. Sometimes useful when you create one-off objects
-- and call methods on them:
--
-- @
--    (createObject arg1) ## startUp arg2
-- @
--
-- instead of the wieldier,
--
-- @
--    obj <- createObject arg1
--    obj # startUp arg2          or createObject arg1 >>= (startUp arg2)
-- @
-- 
( ## ) :: IO a -> (a -> IO b) -> IO b
mObj ## method        = mObj >>= method


--IPersistFile - doesn't really belong here..

data PersistFile a    = PersistFile
type IPersistFile a   = IUnknown (PersistFile a)

iidIPersistFile       :: IID (IPersistFile ())
iidIPersistFile       = mkIID "{0000010B-0000-0000-C000-000000000046}"

-- | @coCreateInstance@ is the basic COM way of creating components. It takes
-- a 'CLSID', an interface to aggregate on, a process context and an IID to 
-- create an object:
--
-- @
--   coCreateInstance clsidAgentServer interfaceNULL LocalProcess iidIAgent
-- @
--
coCreateInstance :: CLSID 
     -> Maybe (IUnknown b)  
     -> CLSCTX 
     -> IID (IUnknown a) 
     -> IO (IUnknown a)
coCreateInstance clsid inner context iid = do
  ppvObject <- allocOutPtr
  clsid     <- marshallCLSID clsid
  inner     <- marshallInner inner
  let ctxt   = fromEnum context
  iid       <- marshallIID iid
  Base.coCreateInstance (castForeignPtr clsid) inner (fromIntegral ctxt)
           (castForeignPtr iid) ppvObject
  doThenFree free (readIUnknown False{-finalise only-}) ppvObject

coCreateInstanceEx :: CLSID 
       -> Maybe (IUnknown b)  
       -> CLSCTX 
       -> Maybe COSERVERINFO
       -> IID (IUnknown a) 
       -> IO (IUnknown a)
coCreateInstanceEx clsid pUnkOuter context mbServ iid = do
  clsid     <- marshallCLSID clsid
  pUnkOuter <- marshallInner pUnkOuter
  let ctxt   = fromEnum context
  iid       <- copyGUID (iidToGUID iid)
  let mqi = [ MULTI_QI iid nullPtr 0 ]
  r <- Base.coCreateInstanceEx (castForeignPtr clsid) pUnkOuter (fromIntegral ctxt) mbServ mqi
  case r of
    (MULTI_QI iid pItf hr:_) -> do
      coFree iid
      checkHR hr
      unmarshallIUnknown True{-finalise it-} pItf
    _ -> coFailHR e_FAIL

marshallInner :: Maybe (IUnknown a) -> IO (ForeignPtr b)
marshallInner Nothing  = return nullFO
marshallInner (Just v) = marshallIUnknown v

-- | @createObject@ creates an object from its progID: @createObject "Agent.Server"@.
-- @getObject@ creates an object from its progID and initializes it with a given file:
-- @getObject "spreadsheet.exl" "Excel.Application"@. If the filename is empty,
-- @getObject@ calls @getActiveObject@.
-- @getActiveObject@ tries to connect to an already running instance of the component:
-- @getActiveObject "Word.Application"@. 
-- @getFileObject@ opens a file or url and loads the associated or persistent object in it:
-- @getFileObject "spreadsheet.spd"@. 
-- @coCreateInstance@ is the basic com way of creating components. It takes
-- a CLSID, process context and IID to create an object: 
-- @coCreateInstance clsidAgentServer Nothing LocalProcess iidIAgent@.
--
-- NOTE: prepend @co@ to specify the initial IID, otherwise @iidIDispatch@ is
-- used (see 'System.Win32.Com.Automation' for more).
-- 
coCreateObject :: ProgID -> IID (IUnknown a) -> IO (IUnknown a)
coCreateObject progid iid = do
    clsid  <- clsidFromProgID progid
    coCreateInstance clsid Nothing AnyProcess iid

-- | Get Object from File and ProgID.
coGetFileObject :: String -> ProgID -> IID (IUnknown a) -> IO (IUnknown a)
coGetFileObject ""    progid iid = coGetActiveObject progid iid
coGetFileObject fname progid iid = do
    pf <- coCreateObject progid iidIPersistFile
    stackWideString fname $ \pfname -> do
      persistfileLoad pf pfname 0
      pf # queryInterface iid

-- | Look up and activate the given active/running object.
coGetActiveObject :: ProgID -> IID (IUnknown a) -> IO (IUnknown a)
coGetActiveObject progid iid = do
  clsid   <- clsidFromProgID progid
  iface   <- primGetActiveObject clsid
               `coOnFail` ("Could not connect to component '" ++ progid ++ "'")
  iface # queryInterface iid

primGetActiveObject :: CLSID -> IO (IUnknown a)
primGetActiveObject clsid = do
  clsid     <- marshallCLSID clsid
  ppvObject <- allocOutPtr
  hr        <- getActiveObject (castForeignPtr clsid) nullPtr ppvObject
  doThenFree free (readIUnknown False{-finalise only-}) ppvObject


-- | Bind to an object via its /moniker string/ or display name.
coGetObject :: String -> IID (IUnknown a) -> IO (IUnknown a)
coGetObject fname iid  = do
   stackWideString fname $ \pfname -> do 
      iid <- marshallIID iid
      ppv <- bindObject pfname (castForeignPtr iid)
      doThenFree free (readIUnknown False{-finalise only-}) ppv

--COM initialize/uninitialize:

-- | @coRun act@ is the toplevel action combinator to wrap up your
-- COM actions in. Takes care of calling 'coInitialize' (and un-initialize)
-- for you.
coRun :: IO a -> IO a
coRun io = do
  coInitialize
  v <-
    catchComException io
      (\ err -> do
        when (isCoError err) (putMessage $ coGetErrorString err)
        coUnInitialize
        throwIOComException err)
  coUnInitialize
  return v

-- | @coPerformIO act@ runs @act@ within an exception handler that
-- catches and displays any COM API errors in a message box. For debugging
-- purposes, mostly.
coPerformIO :: IO a -> IO a
coPerformIO io =
 catchComException io
       ( \ err -> do 
            putMessage (coGetErrorString err)
            throwIOComException err)

coUnsafePerformIO :: IO a -> a
coUnsafePerformIO = unsafePerformIO . coPerformIO

-- | @printMessage val@ /show/s @val@ in a message box.
printMessage :: Show a => a -> IO ()
printMessage x = putMessage (show x)

-- | @putMessage str@ displays @str@ in an informational message box containing an OK button.
putMessage :: String -> IO ()
putMessage msg = 
  stackString msg               $ \ _ m -> 
  stackString "Haskell message" $ \ _ t -> 
  Base.messageBox m t 0x40040
    {- To mere mortals, that's MB_OK | MB_ICONINFORMATION | MB_TOPMOST :-) -}

-- | @messageBox msg title flg@ displays a message box with the given title and content.
-- The @flg@ parameter is the bit pattern that makes up the @MB_*@ settings you want
-- to use (cf. underlying Win32 API documentation for @MessageBox@.)
messageBox :: String -> String -> Word32 -> IO ()
messageBox msg title flg = 
  stackString msg             $ \ _ m -> 
  stackString title           $ \ _ t -> 
  Base.messageBox m t flg

-- | @outputDebugString str@ adds an 
outputDebugString :: String -> IO ()
outputDebugString msg = primOutputDebugString ("haskell-com: " ++ msg ++ "\n")

{-
 Really belongs elsewhere...getting info of what kind of
 platform we're on. 
-}
data OSVersionInfo 
 = OSVersionInfo Word32 Word32 Word32

isWindowsNT :: OSVersionInfo -> Bool
isWindowsNT (OSVersionInfo _ _ 2{-VER_PLATFORM_WIN32_NT-}) = True
isWindowsNT _ = False

isWindows95 :: OSVersionInfo -> Bool
isWindows95 (OSVersionInfo _ 0 1{-VER_PLATFORM_WIN32_WINDOWS-}) = True
isWindows95 _ = False

isWindows98 :: OSVersionInfo -> Bool
isWindows98 (OSVersionInfo _ x 1{-VER_PLATFORM_WIN32_WINDOWS-}) = x /= 0
isWindows98 _ = False

versionInfo :: OSVersionInfo
versionInfo = unsafePerformIO $ do
  (j,n,d) <- primGetVersionInfo
  return (OSVersionInfo j n d)

-- | The @CLSCTX@ enumeration is used by @comCreateInstance@ to specify 
-- execution context in which we'd like to component to be created
-- (just use @AnyProcess@ if you're not too fussed..)
--
data CLSCTX 
 = CLSCTX_INPROC_SERVER 
 | CLSCTX_INPROC_HANDLER
 | CLSCTX_LOCAL_SERVER 
 | CLSCTX_INPROC_SERVER16
 | CLSCTX_REMOTE_SERVER
 | CLSCTX_INPROC_HANDLER16
 | CLSCTX_INPROC_SERVERX86
 | CLSCTX_INPROC_HANDLERX86
 | LocalProcess
 | InProcess
 | ServerProcess
 | AnyProcess
 deriving (Show)

instance Enum CLSCTX where
  fromEnum ctx =
    case ctx of
     CLSCTX_INPROC_SERVER -> 1
     CLSCTX_INPROC_HANDLER -> 2
     CLSCTX_LOCAL_SERVER -> 4
     CLSCTX_INPROC_SERVER16 -> 8
     CLSCTX_REMOTE_SERVER -> 16
     CLSCTX_INPROC_HANDLER16 -> 32
     CLSCTX_INPROC_SERVERX86 -> 64
     CLSCTX_INPROC_HANDLERX86 -> 128
     LocalProcess   -> localProcess
     InProcess      -> inProcess
     ServerProcess  -> serverProcess
     AnyProcess     -> anyProcess

  toEnum x =
   case x of
     1    -> CLSCTX_INPROC_SERVER
     2    -> CLSCTX_INPROC_HANDLER
     8    -> CLSCTX_INPROC_SERVER16
     16   -> CLSCTX_REMOTE_SERVER
     32   -> CLSCTX_INPROC_HANDLER16
     64   -> CLSCTX_INPROC_SERVERX86
     128  -> CLSCTX_INPROC_HANDLERX86
     0x04 -> LocalProcess
     0x0b -> InProcess
     0x0d -> ServerProcess
     4    -> CLSCTX_LOCAL_SERVER
     _    -> AnyProcess


localProcess    :: Int
localProcess    = 0x04
inProcess       :: Int
inProcess       = 0x0b
serverProcess   :: Int
serverProcess   = 0x0d
anyProcess      :: Int
anyProcess      = 0x0f


--VTable method invocation wrappers:

invokeAndCheck :: (Ptr any -> Ptr b -> IO HRESULT) -> Int -> IUnknown a -> IO ()
invokeAndCheck meth offset iptr = do
  hr <- primInvokeItFO meth offset (marshallIUnknown iptr)
  checkHR hr

-- | @invokeIt (\ methPtr ip -> action) offset obj@ sets up a vtbl-indexed
-- COM call, unmarshalling and indexing @obj@ before passing it along to the
-- method argument. The first argument is typically an FFI wrapped call to
-- a function pointer (@methPtr@ here).
--
-- 
invokeIt :: (Ptr any -> Ptr c -> IO a) -> Int -> IUnknown b -> IO a
invokeIt meth offset iptr = primInvokeItFO meth offset (marshallIUnknown iptr)

{-
Library provided stubs for IEnum* interfaces - the HaskellDirect compiler
knows how to generate code for these:
-}
enumNext :: Word32 -> (Ptr any -> IO a) -> Word32 -> IUnknown b -> IO [a]
enumNext szof read_elt celt iptr = do
    ptr     <- allocBytes (fromIntegral (celt * szof))
    po      <- allocBytes (fromIntegral sizeofWord32)
    invokeIt (\ methPtr ip -> primEnumNext methPtr ip celt ptr po) 3 iptr
    elts_read <- readWord32 (castPtr po)
--    v         <- peek ((castPtr ptr) :: Ptr (Ptr a))
    unmarshalllist szof 0 elts_read read_elt ptr

enumNextOne :: Word32 -> (Ptr any -> IO a) -> IUnknown b -> IO (Maybe a)
enumNextOne szof read_elt iptr = 
  allocaBytes (fromIntegral sizeofWord32) $ \ po -> do
    ptr       <- allocBytes (fromIntegral szof)
    invokeIt (\ methPtr ip -> primEnumNext methPtr ip 1 ptr po) 3 iptr
    elts_read <- readWord32 (castPtr po)
    if elts_read <= 0
     then return Nothing
     else do
       x <- read_elt (castPtr ptr)
       return (Just x)

enumSkip :: Word32 -> IUnknown a -> IO ()
enumSkip count iptr = 
   invokeIt (\ methPtr ip -> primEnumSkip methPtr ip count) 4 iptr

enumReset :: IUnknown a -> IO ()
enumReset iptr =
   invokeIt (\ methPtr ip -> primEnumReset methPtr ip) 5 iptr

enumClone :: IUnknown a -> IO (IUnknown b)
enumClone iptr = do
   ppv     <- allocOutPtr
   invokeIt (\ methPtr ip -> primEnumClone methPtr ip ppv) 6 iptr
   doThenFree free (readIUnknown False{-finalise only-}) ppv

{-
BSTRs were introduced by Automation, but their now used in non-Auto
contexts.
-}
data BSTR = BSTR

writeBSTR :: Ptr String -> String -> IO ()
writeBSTR ptr str =
  stackString str $ \_ pstr -> do
    o_stringToBSTR <- prim_System_Win32_Com_Base_stringToBSTR (castPtr pstr) ptr
    checkHR o_stringToBSTR

--readBSTR :: Ptr BSTR -> IO String
readBSTR :: Ptr (Ptr String) -> IO String
readBSTR ptr = do
  ptr' <- peek ptr
  unmarshallBSTR ptr'

unmarshallBSTR :: Ptr String -> IO String
unmarshallBSTR bstr 
  | bstr == nullPtr = return ""
  | len == 0  = return ""
  | otherwise = do
     stackStringLen (4 + fromIntegral len) "" $ \ pstr -> do
        bstrToStringLen (castPtr bstr) len (castPtr pstr)
        unmarshallString pstr
 where
   len  = bstrLen (castPtr bstr)

marshallBSTR :: String -> IO (Ptr String)
marshallBSTR s = 
  stackString s $ \ _ pstr -> do
  ptr <- stringToBSTR (castPtr pstr)
  x   <- peek (castPtr ptr)
  free ptr
  return x

freeBSTR x 
 | x == nullPtr = return ()
 | otherwise    = P.freeBSTR x

-- This type sometimes appear in IDL and tlbs, so
-- to avoid having to depend on wtypes for it, let's
-- simply define it here.
type LPSTR = String

-- | @coFree ptr@ releases storage that has been allocated via the COM task allocator;
-- explicitly via @coAlloc@ or indirectly via the APIs that handed the pointer to your
-- code.
coFree :: Ptr a -> IO ()
coFree p = freeMemory p

-- | @coAlloc sz@ allocates @sz@ bytes from the COM task allocator, returning a pointer.
-- The onus is on the caller to constrain the type of that pointer to capture what the
-- allocated memory points to.
coAlloc :: Word32 -> IO (Ptr a)
coAlloc sz = allocMemory sz

-- | @ProgID@s are represented in Haskell as mere strings
type ProgID = String

-- | @clsidFromProgID progid@ looks up a @ProgID@ and tries to translate it into
-- its registered @CLSID@. Raises an IO exception if the @ProgID@ isn't known.
clsidFromProgID :: ProgID -> IO CLSID
clsidFromProgID progid =
   stackString progid $ \ _ pprogid -> do
     pclsid  <- coAlloc sizeofCLSID
     coOnFail (primCLSIDFromProgID pprogid (castPtr pclsid))
             ("Component '" ++ progid ++ "' is unknown")
     unmarshallCLSID True pclsid

-- | @progIDFromCLSID cid@ is the dual @clsidFromProgID@, attempting to translate
-- in the other direction.
progIDFromCLSID :: CLSID -> IO ProgID
progIDFromCLSID clsid = do
   pclsid    <- marshallCLSID clsid
   pwide     <- primProgIDFromCLSID (castForeignPtr pclsid)
   (pstr,hr) <- wideToString (castPtr pwide)
   checkHR hr
   str       <- unmarshallString (castPtr pstr)
   coFree pstr
   coFree pwide
   return str


-- | Type libraries are identified by a GUID, the @LIBID@.
type LIBID = GUID

mkLIBID :: String -> LIBID
mkLIBID = mkGUID

type LCID = Word32

-- | Representing interface pointers via @IUnknown a@, where @a@ is
-- the particular @IUnknown@-extended interface, e.g., @IUnknown IDispatch_@.
-- If the interface pointer is /just/ @IUnknown@, use @IUnknown ()@.
--
-- Extend this to @IID@s and parameterize them over the interface they
-- represent.
iidIUnknown :: IID (IUnknown ())
iidIUnknown = mkIID "{00000000-0000-0000-C000-000000000046}"

-- | Equality of interface pointers is defined by the COM spec
-- as being equality of IUnknown (pointers to) implementations.
instance Eq (IUnknown_ a) where
   iface1 == iface2    = coEqual (castIface iface1) (castIface iface2)

-- | @castIface obj@ performs a type
castIface :: IUnknown a -> IUnknown b
castIface (Unknown o) = Unknown o

-- | @interfaceNULL@ is the @NULL@ interface pointer.
interfaceNULL :: IUnknown a
interfaceNULL = unsafePerformIO (unmarshallIUnknown False nullPtr)

-- | @isNullInterface iptr@ returns @True@ iff @iptr@ is the NULL pointer.
isNullInterface :: IUnknown a -> Bool
isNullInterface (Unknown ip)    = foreignPtrToPtr ip == nullPtr

-- | The null interface
iidNULL :: IID ()
iidNULL = mkIID "{00000000-0000-0000-0000-000000000000}"

instance Show (IUnknown_ a) where
  showsPrec _ iface   = 
    shows "<interface pointer = " . 
    shows (ifaceToAddr iface)     .
    shows ">"

-- | @queryInterface iid iunk@ queries @iunk@ if it supports the @iid@
-- interface, returning it. Notice that the type parameter to the @IID@
-- matches up with that of the resulting interface pointer, giving you
-- type safety - i.e., you can only use the interface pointer with methods
-- supported by that interface 
queryInterface :: IID (IUnknown b) -> IUnknown a -> IO (IUnknown b)
queryInterface riid iptr = do
    ppvObject <- allocOutPtr
    priid     <- marshallIID riid
    invokeIt (\ methPtr ip -> primQI methPtr ip (castForeignPtr priid) ppvObject) 0 iptr
    doThenFree free (readIUnknown False{-finalise only-}) ppvObject

-- | @addRef iptr@ increases the reference count of the interface pointer @iptr@.
-- Notice that interface pointers are managed and finalized when on the Haskell heap,
-- so manual reference counting is not required (and not encouraged as it could prevent
-- the underlying object from being properly released, should you forget to decrement
-- the ref count with @release@.)
addRef :: IUnknown a -> IO Word32
addRef iptr = invokeIt (\ methPtr ip -> primAddRef methPtr ip) 1 iptr

-- | @addRef iptr@ decrements the reference count of the interface pointer @iptr@.
release :: IUnknown a -> IO Word32
release iptr = invokeIt (\ methPtr ip -> primRelease methPtr ip) 2 iptr

withQueryInterface :: IID (IUnknown b)
             -> IUnknown a
             -> (IUnknown b -> IO c)
             -> IO c
withQueryInterface iid unk action 
 = bracket (queryInterface iid unk) release action

--HDirect generated stub needed by @coGetObject@:
persistfileLoad :: IPersistFile a -> Ptr Wchar_t -> Word32 -> IO ()
persistfileLoad iptr pszFileName dwMode =
    invokeIt (\ methPtr ip -> primPersistLoad methPtr ip pszFileName dwMode) 5 iptr

-- | @GUID@ is the Haskell representation for COM GUIDs. 
newtype GUID     = GUID (ForeignPtr ()) --(Pointer Guid)

data Guid   = Guid

mkGUID :: String -> GUID
mkGUID str = unsafePerformIO (stringToGUID str)

-- | @newGUID@ generates a new unique GUID.
newGUID :: IO GUID
newGUID = do
  pg  <- coAlloc sizeofGUID
  ng  <- makeFO pg (castPtrToFunPtr finalFreeMemory)
  primNewGUID ng
  return (GUID ng)

nullGUID :: GUID
nullGUID = unsafePerformIO $ do
  x <- primNullIID
  p <- makeFO x (castPtrToFunPtr finalNoFree) --primNoFree
  return (GUID p)

marshallGUID :: GUID -> IO (ForeignPtr GUID)
marshallGUID (GUID ptr) = return (castForeignPtr ptr)

-- | A version of the GUID marshaller which copies rather
-- than hands back a pointer to the (immutable) GUID.
copyGUID :: GUID -> IO (Ptr ())
copyGUID (GUID ptr) = do
    pg  <- coAlloc sizeofGUID
    primCopyGUID ptr pg
    return pg

-- | @unmarshallGUID finalize ptr@ unpacks a pointer to an incoming
-- GUID, wrapping it up as a Haskell 'GUID'. If @finalize@ is @True@,
-- the GUID is assumed allocated via the COM task allocator and will
-- be freed/finalized when the 'GUID' becomes garbage.
unmarshallGUID :: Bool -> Ptr GUID -> IO GUID
unmarshallGUID finaliseMe ptr = do
     -- ToDo: verify that HDirect *never ever* allocates and
     --       stores a GUID in malloc()-space, but consistently
     --       uses the COM task allocator. (Why? because the
     --       finalizer below will tell the COM task allocator
     --       to free the GUID once done with it)
   f  <- makeFO ptr (castPtrToFunPtr $ if finaliseMe then finalFreeMemory else finalNoFree)
   return (GUID f)

-- | @writeGUID ptr g@ packs the Haskell 'GUID' into the pointer; that is,
-- it writes a pointer to the GUID value to @ptr@ -- no copying of underlying
-- structure.
writeGUID :: Ptr GUID -> GUID -> IO ()
writeGUID ptr (GUID g) = poke (castPtr ptr) (foreignPtrToPtr g)

readGUID :: Bool -> Ptr GUID -> IO GUID
readGUID finaliseMe ptr = do
--  ptr  <- peek ptr
  unmarshallGUID finaliseMe ptr

sizeofGUID  :: Word32
sizeofGUID  = 16

-- | @stringToGUID "{00000000-0000-0000-C000-0000 0000 0046}"@ translates the
-- COM string representation for GUIDs into an actual 'GUID' value.
stringToGUID :: String -> IO GUID
stringToGUID str =
   stackWideString str $ \xstr -> do
   pg <- coAlloc sizeofGUID
   primStringToGUID xstr (castPtr pg)
   unmarshallGUID True pg

-- | @stringFromGUID g@ converts the 'GUID' @g@ into the COM string representation
-- @{aaaaaaaa-bbbb-cccc-dddd-eeeeeeeeeeee}@
stringFromGUID :: GUID -> IO String
stringFromGUID guid = do
   pguid     <- marshallGUID guid
   pwide     <- primGUIDToString (castForeignPtr pguid)
   (pstr,hr) <- wideToString (castPtr pwide)
   checkHR hr
   str       <- unmarshallString (castPtr pstr)
   coFree pstr
   coFree pwide
   return str

guidToString :: GUID -> String
guidToString ptr = unsafePerformIO (stringFromGUID ptr)

{-
-}
-- | Representation of @IID@s: Give the interface identifier
-- a type parameter, so that when we come to define the Haskell
-- type of @IUnknown.QueryInterface()@ we can rely on the type checker
-- to ensure that the @IID@ passed to @QueryInterface@ agrees with
-- the interface at which we're using the interface pointer that's
-- returned
newtype IID a  = IID GUID   deriving ( Eq )

newtype CLSID  = CLSID GUID deriving ( Eq )

mkIID   :: String -> IID a
mkIID str   = IID (mkGUID str)

mkCLSID :: String -> CLSID
mkCLSID str = CLSID (mkGUID str)

-- no need to provide marshallers for these, the IDL compiler
-- knows that they're both represented by GUIDs.

stringToIID :: String -> IID a
stringToIID str = mkIID str

stringToCLSID :: String -> CLSID
stringToCLSID str = mkCLSID str

iidToString :: IID a -> String
iidToString (IID i) = guidToString i

clsidToString :: CLSID -> String
clsidToString (CLSID clsid) = guidToString clsid

iidToGUID :: IID a -> GUID
iidToGUID (IID g) = g

castIID :: IID a -> IID b
castIID (IID i) = IID i

clsidToGUID :: CLSID -> GUID
clsidToGUID (CLSID g) = g

clsidToDisplayName :: CLSID  -> String
clsidToDisplayName (CLSID g) = "clsid:" ++ tail (init (show g))

guidToIID :: GUID -> IID a
guidToIID g = IID g

guidToCLSID :: GUID -> CLSID
guidToCLSID g = CLSID g

instance Show (IID a) where
  showsPrec _ (IID i)  = showString (guidToString i)

instance Show CLSID where
  showsPrec _ (CLSID c)  = showString (guidToString c)

instance Show GUID where
  showsPrec _ guid     = showString (guidToString guid)

instance Eq GUID where
  (GUID x) == (GUID y) = unsafePerformIO $ do
     return (isEqualGUID x y)

marshallIID :: IID a -> IO (ForeignPtr (IID a))
marshallIID (IID x) = marshallGUID x >>= return.castForeignPtr
unmarshallIID :: Bool -> Ptr (IID a) -> IO (IID a)
unmarshallIID finaliseMe x = do
  i <- unmarshallGUID finaliseMe (castPtr x)
  return (IID i)

copyIID (IID x) = copyGUID x

readIID :: Bool -> Ptr (Ptr (IID a)) -> IO (IID a)
readIID finaliseMe ptr = do
  a  <- peek ptr
  unmarshallIID finaliseMe (castPtr a)

writeIID :: Ptr (IID a) -> IID a -> IO ()
writeIID ptr (IID i) = writeGUID (castPtr ptr) i

--------

marshallCLSID (CLSID x) = marshallGUID x

unmarshallCLSID :: Bool -> Ptr CLSID -> IO CLSID
unmarshallCLSID finaliseMe x = do
  i <- unmarshallGUID finaliseMe (castPtr x)
  return (CLSID i)

copyCLSID (CLSID x) = copyGUID x

readCLSID :: Bool -> Ptr (Ptr CLSID) -> IO CLSID
readCLSID finaliseMe ptr = do
  a  <- peek ptr
  unmarshallCLSID finaliseMe (castPtr a)

writeCLSID :: Ptr CLSID -> CLSID -> IO ()
writeCLSID ptr (CLSID i) = writeGUID (castPtr ptr) i

sizeofCLSID = sizeofGUID

coInitialize :: IO ()
coInitialize = comInitialize

coUnInitialize :: IO ()
coUnInitialize = comUnInitialize

sizeofIID = sizeofGUID

coEqual :: IUnknown a -> IUnknown b -> Bool
coEqual ip1 ip2 = unsafePerformIO $ primComEqual (castIface ip1) (castIface ip2)

--Interface pointer marshallers:

-- marshallIUnknown is in Base.idl

unmarshallIUnknown :: Bool -> Ptr b -> IO (IUnknown a)
unmarshallIUnknown finaliseMe x = do
   ip <- addrToIPointer finaliseMe x
   case finaliseMe of
     True | x /= nullPtr -> ip # addRef >> return ip
     _    -> return ip

unmarshallIUnknownFO :: ForeignPtr b -> IO (IUnknown a)
unmarshallIUnknownFO i = return (Unknown (castForeignPtr i))
  -- ToDo: I believe it is correct never to do an AddRef()
  --       here, but double-check the spec.

{-
  addRefMe == True  => attach finaliser (which calls Release()), and
             call addRef on i-pointer before returning.
           == False => attach finaliser (which calls Release()) only.

  The former case is used when you receive an i-pointer from the outside
  world and want to copy a reference to it into the Haskell heap. This
  does not include i-pointers you receive via [out] pointers when calling
  a COM component method from Haskell, where it is the obligation of the
  server filling in the [out] pointer to call addRef() for you.
-}
readIUnknown :: Bool -> Ptr b -> IO (IUnknown a)
readIUnknown addRefMe x = do
  ptr <- peek (castPtr x)
  ip <- addrToIPointer True ptr
  case addRefMe of
     True | x /= nullPtr -> ip # addRef >> return ip
     _    -> return ip

writeIUnknown :: Bool -> Ptr (Ptr (IUnknown b)) -> IUnknown a -> IO ()
writeIUnknown addRefMe x v = do
   let a = ifaceToAddr v
   when (addRefMe && a /= nullPtr)
        (v # addRef >> return ())
   writePtr x a

{-
@withObject@ applies every method in a list to an 
object: @withObject genie [showUp, speak "hi", hide]@.
@withMethod@ applies every argument in a list to a
method: @genie # withMethod speak ["hello", "world"]@.
-}

withObject_ :: IUnknown a -> [IUnknown a -> IO b] -> IO ()
withObject_ obj       = sequence_ .  map ( obj # ) 

withMethod_ :: (a -> IUnknown b -> IO c) -> [a] -> IUnknown b -> IO ()
withMethod_ method args obj = sequence_ $ map (\x -> obj # method x) args

withObject :: IUnknown a -> [IUnknown a -> IO b] -> IO [b]
withObject obj        = sequence . map ( obj # )

withMethod :: (a -> IUnknown b -> IO c) -> [a] -> IUnknown b -> IO [c]
withMethod method args obj = sequence $ map (\x -> obj # method x) args

loadTypeLib :: String -> IO (IUnknown a)
loadTypeLib fname = do
    ptr <- allocOutPtr
    stackWideString fname $ \pfname -> do
      Base.loadTypeLib pfname ptr
      doThenFree free (readIUnknown False{-finalise only-}) ptr

loadRegTypeLib :: GUID -> Int -> Int -> Int -> IO (IUnknown a)
loadRegTypeLib guid maj min lcid = do
    ptr     <- allocOutPtr
    p_guid  <- marshallGUID guid
    Base.loadRegTypeLib (castForeignPtr p_guid)
             (fromIntegral maj) (fromIntegral min)
         (fromIntegral lcid) ptr
    doThenFree free (readIUnknown False{-finalise only-}) ptr

queryPathOfRegTypeLib :: GUID
          -> Word16
          -> Word16
          -> IO String
queryPathOfRegTypeLib gd maj min = do
    pgd   <- marshallGUID gd
    pbstr <- primQueryPathOfRegTypeLib (castForeignPtr pgd) maj min
    if nullPtr == pbstr then
        return ""
      else do
        str <- unmarshallBSTR (castPtr pbstr)
        freeBSTR pbstr
        return str

createTypeLib :: String -> IO (IUnknown a) --(ICreateTypeLib a)
createTypeLib nm = do
   wstr <- stringToWide nm
   pptr <- primCreateTypeLib 1{-SYS_WIN32-} wstr
   doThenFree free (readIUnknown False{-finalise only-}) pptr

loadTypeLibEx :: String -> Bool -> IO (IUnknown a)
loadTypeLibEx path reg_tlb = do
    let
      {-
        This Int is used to map onto the following enum

         typedef enum tagREGKIND { REGKIND_DEFAULT, REGKIND_REGISTER, REGKIND_NONE };
      -}
     rkind :: Int
     rkind
      | reg_tlb   = 1
      | otherwise = 2

    out_ptr <- allocOutPtr
    stackWideString path $ \pfname -> do
      Base.loadTypeLibEx pfname (fromIntegral rkind) out_ptr
      doThenFree free (readIUnknown False{-finalise only-}) out_ptr