com 1.1 → 1.2.0

raw patch · 15 files changed

+162/−241 lines, 15 filesdep ~base

Dependency ranges changed: base

Files

System/Win32/Com.hs +9/−4
System/Win32/Com/Automation.hs +4/−53
System/Win32/Com/Automation/Base.hs +0/−21
System/Win32/Com/Automation/TypeLib.hs +0/−10
System/Win32/Com/Base.hs +48/−18
System/Win32/Com/ClassFactory.hs +0/−1
System/Win32/Com/Exception.hs +81/−83
System/Win32/Com/HDirect/HDirect.hs +1/−32
System/Win32/Com/HDirect/Pointer.hs +0/−12
System/Win32/Com/HDirect/PointerPrim.hs +1/−1
System/Win32/Com/HDirect/WideString.hs +1/−0
System/Win32/Com/Server.hs +1/−1
System/Win32/Com/Server/StdDispatch.hs +1/−1
com.cabal +13/−4
include/PointerSrc.h +2/−0

System/Win32/Com.hs view

@@ -86,6 +86,11 @@     , coGetErrorHR      -- :: IOError -> HRESULT
     , coGetErrorString  -- :: IOError -> String
     , hresultToString   -- :: HRESULT -> IO String
+    
+    , ComException(..)
+    , catchComException
+    , throwIOComException
+    , throwComException
 
       -- component creation:
     , coCreateInstance -- :: CLSID -> Maybe (IUnknown b) -> CLSCTX
@@ -353,20 +358,20 @@ coRun io = do
   coInitialize
   v <-
-    catch io
+    catchComException io
       (\ err -> do
         when (isCoError err) (putMessage $ coGetErrorString err)
         coUnInitialize
-        ioError err)
+        throwIOComException err)
   coUnInitialize
   return v
 
 coPerformIO :: IO a -> IO a
 coPerformIO io =
- catch io
+ catchComException io
        ( \ err -> do 
 	    putMessage (coGetErrorString err)
-            ioError err 
+            throwIOComException err 
        )
 
 coUnsafePerformIO :: IO a -> a

System/Win32/Com/Automation.hs view

@@ -103,10 +103,8 @@ 
       enumVariants,
       
-{- BEGIN_GHC_ONLY
       marshallCurrency, unmarshallCurrency,
       readCurrency, writeCurrency,
-   END_GHC_ONLY -}
       sizeofCurrency,
       
       VARENUM(..),
@@ -259,15 +257,13 @@    bstr        <- allocBSTR name
    (dispid,hr) <- dispatchGetMemberID (castIface obj) bstr lcidNeutral
                        `always` freeBSTR bstr
-   checkHR hr  `catch` (handleErr hr)
+   checkHR hr  `catchComException` (handleErr hr)
    return dispid
  where
   handleErr hr err
-    | hr == dISP_E_UNKNOWNNAME =
-       coFail ("method '" ++ name ++ "' called but not supported by object")
+    | hr == dISP_E_UNKNOWNNAME = coFail ("method '" ++ name ++ "' called but not supported by object") -- "
     | otherwise		      = errorMember name err
 
-
 {-
 Type definitions for marshalling functions. Variants are represented
 as functions that can read or write a value from or to a variant structure.
@@ -386,12 +382,7 @@ 
   vtEltType _ = VT_I1
 
-{- BEGIN_GHC_ONLY
 instance Variant Int64 where
-   END_GHC_ONLY -}
-{- BEGIN_NOT_FOR_GHC -}
-instance Variant Integer where
-{- END_NOT_FOR_GHC -}
   inVariant   = inInt64
   resVariant  = resInt64
   defaultVariant = defaultInt64
@@ -419,14 +410,12 @@ 
   vtEltType _ = VT_UI4
 
-{- BEGIN_GHC_ONLY
 instance Variant Word64 where
   inVariant   = inWord64
   resVariant  = resWord64
   defaultVariant = defaultWord64
 
   vtEltType _ = VT_DECIMAL  -- since VT_UI8 isn't supported in VARIANTs.
-   END_GHC_ONLY -}
 
 instance Variant Float where
   inVariant   = inFloat
@@ -627,12 +616,7 @@ inoutHRESULT = inoutInt32
 outHRESULT   = outInt32
 
-{- BEGIN_GHC_ONLY
 defaultInt64 :: Int64
-   END_GHC_ONLY -}
-{- BEGIN_NOT_FOR_GHC -}
-defaultInt64 :: Integer
-{- END_NOT_FOR_GHC -}
 defaultInt64        = 0
 
 inInt64 :: ArgIn Currency
@@ -700,32 +684,17 @@ inoutWord32 i            = (inWord32 i,resWord32)
 outWord32                = inoutWord32 defaultWord32
 
-{- BEGIN_GHC_ONLY
 defaultWord64 :: Word64
-   END_GHC_ONLY -}
-{- BEGIN_NOT_FOR_GHC -}
-defaultWord64 :: Integer
-{- END_NOT_FOR_GHC -}
 defaultWord64            = 0
 
-{- BEGIN_GHC_ONLY
 inWord64 :: ArgIn Word64
-   END_GHC_ONLY -}
-{- BEGIN_NOT_FOR_GHC -}
-inWord64 :: ArgIn Integer
-{- END_NOT_FOR_GHC -}
 inWord64 f  = 
    let
     (hi,lo) = toInteger f `divMod` (toInteger (maxBound :: Int) + 1)
    in
    writeVarWord64 (fromInteger hi) (fromInteger lo)
 
-{- BEGIN_GHC_ONLY
 resWord64 :: ArgRes Word64
-   END_GHC_ONLY -}
-{- BEGIN_NOT_FOR_GHC -}
-resWord64 :: ArgRes Integer
-{- END_NOT_FOR_GHC -}
 resWord64           = 
    let
     coerceW = fromIntegral
@@ -840,12 +809,7 @@ --Currency:
 
 type Currency 
-{- BEGIN_GHC_ONLY
    = Int64
-   END_GHC_ONLY -}
-{- BEGIN_NOT_FOR_GHC -}
-   = Integer
-{- END_NOT_FOR_GHC -}
 
 defaultCurrency :: Currency
 defaultCurrency  = 0
@@ -856,12 +820,7 @@ inCurrency :: ArgIn Currency
 inCurrency f  = 
    let
-{- BEGIN_NOT_FOR_GHC -}
-    (hi,lo) = f `divMod` (toInteger (maxBound :: Int) + 1)
-{- END_NOT_FOR_GHC -}
-{- BEGIN_GHC_ONLY
     (hi,lo) = f `divMod` (fromIntegral (maxBound :: Int) + 1)
-   END_GHC_ONLY -}
    in
    writeVarCurrency (fromIntegral (fromIntegral hi)) (fromIntegral (fromIntegral lo))
 
@@ -869,13 +828,7 @@ resCurrency :: ArgRes Currency
 resCurrency           = 
    let
-{- BEGIN_GHC_ONLY
     coerceI = fromIntegral
-   END_GHC_ONLY -}
-{- BEGIN_NOT_FOR_GHC -}
-    coerceI = toInteger
-{- END_NOT_FOR_GHC -}
-    
     readCur v = do
       (hi,lo) <- readVarCurrency v
       return (coerceI (fromIntegral hi) * (coerceI (maxBound :: Int) + 1) +
@@ -1384,12 +1337,12 @@ 
 --Error reporting:
 
-errorMember :: String -> IOError -> IO a
+errorMember :: String -> Either IOError ComException -> IO a
 errorMember member err
       = coFail ("method '" ++ member ++ "': " ++ (coGetErrorString err))
 
 catchMethError :: Member -> IO a -> IO a
-catchMethError member act = catch act (errorMember member)
+catchMethError member act = catchComException act (errorMember member)
 
 --Unmarshall the @out@ arguments.
 
@@ -1652,12 +1605,10 @@   action
   return x
 
-{- BEGIN_GHC_ONLY
 marshallCurrency = marshallInt64
 unmarshallCurrency = unmarshallInt64
 readCurrency = readInt64
 writeCurrency = writeInt64
-   END_GHC_ONLY -}
 sizeofCurrency = sizeofInt64
 
 data VARENUM

System/Win32/Com/Automation/Base.hs view

@@ -23,17 +23,6 @@ import Foreign.ForeignPtr ( ForeignPtr, withForeignPtr )
 import Foreign.Ptr
 
-{-
-#if defined(FOR_GHC)
-#define BEGIN_GHC_ONLY -}
-#define END_GHC_ONLY   {-
-#define BEGIN_NOT_FOR_GHC {-
-#define END_NOT_FOR_GHC -}
-#define ELSE_FOR_GHC -}-}
-#endif
--}
-
-
 data VARIANT_ = VARIANT_
 type VARIANT = Ptr VARIANT_
 sizeofBSTR = sizeofPtr
@@ -71,20 +60,10 @@   variantInit x
   return x
 
-{- BEGIN_GHC_ONLY 
 foreign import ccall "writeVarInt" writeVarStablePtr
-   END_GHC_ONLY -}
-{- BEGIN_NOT_FOR_GHC -}
-primitive writeVarStablePtr "prim_AutoPrim_writeVarInt"
-{- END_NOT_FOR_GHC -}
      :: StablePtr a -> Ptr (StablePtr a) -> IO ()
 
-{- BEGIN_GHC_ONLY 
 foreign import ccall "readVarInt" prim_readVarStablePtr 
-   END_GHC_ONLY -}
-{- BEGIN_NOT_FOR_GHC -}
-primitive prim_readVarStablePtr "prim_AutoPrim_readVarInt"
-{- END_NOT_FOR_GHC -}
      :: Ptr (StablePtr a) -> Ptr b -> IO Int32
 
 readVarStablePtr :: VARIANT -> IO (StablePtr a)

System/Win32/Com/Automation/TypeLib.hs view

@@ -36,16 +36,6 @@                                             readWideString, marshallWideString, freeWideString, 
                                             WideString, unmarshallWideString)
 
-{-
-#if defined(FOR_GHC)
-#define BEGIN_GHC_ONLY -}
-#define END_GHC_ONLY   {-
-#define BEGIN_NOT_FOR_GHC {-
-#define END_NOT_FOR_GHC -}
-#define ELSE_FOR_GHC -}-}
-#endif
--}
-
 
 {- BEGIN_C_CODE
 #include "StdTypes.h"

System/Win32/Com/Base.hs view

@@ -1,4 +1,4 @@-{-# OPTIONS -#include "comPrim.h" #-}
+{-# OPTIONS_GHC -XCPP -fglasgow-exts -#include "comPrim.h" #-}
 -- Automatically generated by HaskellDirect (ihc.exe), snapshot 171208
 -- Created: 23:37 Pacific Standard Time, Wednesday 17 December, 2008
 -- Command line: -fno-qualified-names -fno-imports -fno-export-lists -fout-pointers-are-not-refs -c System/Win32/Com/Base.idl -o System/Win32/Com/Base.hs
@@ -12,9 +12,6 @@ import Foreign.ForeignPtr
 import Foreign.Ptr
 import Data.Dynamic
-{- BEGIN_GHC_ONLY
-import GHC.IOBase
-   END_GHC_ONLY -}
 import Data.Int
 import Data.Word       ( Word32 )
 import System.IO.Unsafe ( unsafePerformIO )
@@ -22,6 +19,12 @@ 		    readWideString, writeWideString )
 import IO         ( hPutStrLn, stderr )
 
+import Control.Exception
+import Data.Typeable
+#if BASE <=3
+import GHC.IOBase
+#endif
+
 newtype IUnknown_ a  = Unknown  (ForeignPtr ())
 type IUnknown  a  = IUnknown_ a
 
@@ -51,12 +54,45 @@     str <- stringFromHR hr
     coFailWithHR hr str
 
-{- BEGIN_GHC_ONLY
--- ghc-specific
-newtype ComError = ComError Int32
+newtype ComError = ComError HRESULT
+  deriving ( Show )
 
-comErrorTc = mkTyCon "ComError"
+data ComException
+ = ComException
+     { comException     :: ComError
+     , comExceptionMsg  :: String
+     } deriving (Typeable,Show)
 
+comExceptionHR :: ComException -> HRESULT
+comExceptionHR ComException{comException=ComError hr} = hr
+
+comErrorTc = mkTyCon "System.Win32.Com.Base.ComError"
+
+#if !defined(BASE) || BASE > 3 
+data SomeCOMException = forall e . Exception e => SomeCOMException e 
+    deriving Typeable 
+
+instance Show SomeCOMException where 
+    show (SomeCOMException e) = show e 
+
+instance Exception SomeCOMException 
+
+comToException :: Exception e => e -> SomeException 
+comToException = toException . SomeCOMException 
+
+comFromException :: Exception e => SomeException -> Maybe e 
+comFromException x = do 
+    SomeCOMException a <- fromException x 
+    cast a 
+
+throwComException :: ComException -> IO a
+throwComException c = throwIO (toException c)
+
+instance Exception ComException where
+  toException   = comToException
+  fromException = comFromException
+
+#else
 instance Typeable ComError where
 #if __GLASGOW_HASKELL__ < 604
    typeOf _ = mkAppTy comErrorTc []
@@ -64,23 +100,17 @@    typeOf _ = mkTyConApp comErrorTc []
 #endif
 
-coFailWithHR :: HRESULT -> String -> IO a
-coFailWithHR hr msg = 
-  ioException (IOError Nothing (DynIOError (toDyn (ComError hr))) "" msg Nothing)
-   END_GHC_ONLY -}
-
-{- BEGIN_NOT_FOR_GHC -}
-coPrefix   = "Com error: "
+throwComException :: ComException -> IO a
+throwComException c = throwDyn c
+#endif
 
 coFailWithHR :: HRESULT -> String -> IO a
-coFailWithHR hr msg = ioError (userError (coPrefix ++ msg ++ showParen True (shows hr) ""))
-{- END_NOT_FOR_GHC   -}
+coFailWithHR hr msg = throwComException ComException{comException=(ComError hr),comExceptionMsg=msg}
 
 stringFromHR :: HRESULT -> IO String
 stringFromHR hr = do
   pstr <- hresultString hr  -- static memory
   unmarshallString (castPtr pstr)
-
 
 comInitialize :: IO ()
 comInitialize =

System/Win32/Com/ClassFactory.hs view

@@ -1,4 +1,3 @@-{-# OPTIONS -#include "ClassFactory_stub.h" #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  System.Win32.Com.ClassFactory

System/Win32/Com/Exception.hs view

@@ -1,4 +1,4 @@-{-# OPTIONS -#include "comPrim.h" #-}
+{-# OPTIONS -XCPP -#include "comPrim.h" #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  System.Win32.Com.Exception
@@ -20,14 +20,63 @@ import Data.Word
 import Data.Bits
 import Data.Dynamic
-import Data.Maybe ( isJust )
-{- BEGIN_GHC_ONLY
-import GHC.IOBase
-   END_GHC_ONLY -}
+import Data.Maybe ( isJust, fromMaybe )
 import Numeric ( showHex )
 import IO
-import qualified Control.OldException as Control.Exception ( catch, ioErrors )
 
+#if BASE == 3
+import GHC.IOBase
+import Control.Exception
+
+catchComException :: IO a -> (Com_Exception -> IO a) -> IO a
+catchComException act hdlr = 
+   Control.Exception.catch act
+      (\ ex -> 
+        case ex of
+	  DynException d -> 
+	    case fromDynamic d of
+	      Just ce -> hdlr (Right ce)
+	      _       -> throwIO ex
+	  IOException ioe -> hdlr (Left ioe)
+	  _ -> throwIO ex)
+
+catch_ce_ :: IO a -> (Maybe ComException -> IO a) -> IO a
+catch_ce_ act hdlr = 
+   catchComException
+      act 
+      (\ e ->
+        case e of
+	  Left  ioe -> hdlr Nothing
+	  Right ce ->  hdlr (Just ce))
+
+#else
+import Control.Exception
+catchComException :: IO a -> (Com_Exception -> IO a) -> IO a
+catchComException act hdlr = 
+  Control.Exception.catch act
+     (\ e -> 
+        case fromException e of
+	  Just ioe -> hdlr (Left ioe)
+	  _ -> case fromException e of
+	        Just d -> hdlr (Right d)
+		_      -> throwIO e)
+
+catch_ce_ :: IO a -> (Maybe ComException -> IO a) -> IO a
+catch_ce_ act hdlr = 
+   catchComException
+      act 
+      (\ e ->
+        case e of
+	  Left  ioe -> hdlr Nothing
+	  Right ce ->  hdlr (Just ce))
+#endif
+
+type Com_Exception = Either IOException ComException
+
+throwIOComException :: Com_Exception -> IO a
+throwIOComException (Left e) = ioError e
+throwIOComException (Right ce) = throwComException ce
+
 check2HR :: HRESULT -> IO ()
 check2HR hr
       | succeeded hr = return ()
@@ -44,81 +93,37 @@ 	  coFailHR (word32ToInt32 dw)
 
 returnHR :: IO () -> IO HRESULT
-returnHR act = (do
-  act 
-  return s_OK)
-{- BEGIN_GHC_ONLY 
-    `Control.Exception.catch`
-      (\ ex -> 
-        case Control.Exception.ioErrors ex of
-	  Just i -> 
-	    case coGetErrorHR i of
-	      Just x  -> return x
-	      Nothing -> return failure
-	  Nothing -> return failure)
-   END_GHC_ONLY -}
-{- BEGIN_NOT_FOR_GHC -}
-     -- once we can assume that IOError == Exception on the
-     -- Hugs side, no need for this.
-    `IO.catch`
-    (\ ex -> 
-        case coGetErrorHR ex of
-	  Just x  -> return x
-	  Nothing -> return failure)
-{- END_NOT_FOR_GHC -}
+returnHR act = 
+   catch_ce_
+     (act >> return s_OK)
+     (\ mb_hr -> return (maybe failure toHR mb_hr))
  where
+  toHR ComException{comException=(ComError hr)} = hr
    -- better return codes could easily be imagined..
   failure = e_FAIL
 
-isCoError        :: IOError -> Bool
-coGetErrorHR     :: IOError -> Maybe HRESULT
-coGetErrorString :: IOError -> String
 
-{- BEGIN_GHC_ONLY
-isCoError ioe = isJust (coGetErrorHR ioe)
 
-#if __GLASGOW_HASKELL__ >= 505
-coGetErrorHR (IOError _ (DynIOError d) _ _ _) = 
-#else
-coGetErrorHR (IOException (IOError _ (DynIOError d) _ _ _)) = 
-#endif
-  case fromDynamic d of
-    Just (ComError hr) -> Just hr
-    Nothing            -> Nothing
-coGetErrorHR _	= Nothing
-
-#if __GLASGOW_HASKELL__ >= 505
-coGetErrorString ioe@(IOError _ (DynIOError dyn) loc str _)
-#else
-coGetErrorString ioe@(IOException (IOError _ (DynIOError dyn) loc str _))
-#endif
-  = case (fromDynamic dyn) of
-       Just (ComError hr) -> str ++ showParen True (showHex (int32ToWord32 hr)) ""
-       Nothing            -> ioeGetErrorString ioe
-coGetErrorString ioe = ioeGetErrorString ioe
-   END_GHC_ONLY -}
-
-{- BEGIN_NOT_FOR_GHC -}
-
-userPrefix = "User error: "
-prefixLen  = length userPrefix + length coPrefix
-
-isCoError err         = (isUserError err)  &&
-                        (prefix == userPrefix ++ coPrefix)
-                      where
-                        prefix    = take prefixLen (ioeGetErrorString err)
+isCoError        :: Com_Exception -> Bool
+isCoError Right{} = True
+isCoError Left{}  = False
 
---ToDo: try to fish it out from the user string.
-coGetErrorHR _ = Nothing
+coGetException   :: Com_Exception-> Maybe ComException
+coGetException (Right ce) = Just ce
+coGetException _ = Nothing
 
-coGetErrorString e
-  | isCoError e    = drop prefixLen (ioeGetErrorString e)
-  | otherwise      = drop (length userPrefix) (ioeGetErrorString e)
+coGetErrorHR     :: Com_Exception -> Maybe HRESULT
+coGetErrorHR Left{} = Nothing
+coGetErrorHR (Right ce) = Just (case comException ce of (ComError hr) -> hr)
 
-{- END_NOT_FOR_GHC -}
+coGetErrorString :: Com_Exception -> String
+coGetErrorString (Left ioe) = ioeGetErrorString ioe
+coGetErrorString (Right ce) = 
+   comExceptionMsg ce ++ 
+   showParen True (showHex (int32ToWord32 (comExceptionHR ce))) ""
 
-printComError :: IOError -> IO ()
-printComError ioe = putStrLn (coGetErrorString ioe)
+printComError :: Com_Exception -> IO ()
+printComError ce = putStrLn (coGetErrorString ce)
 
 hresultToString :: HRESULT -> IO String
 hresultToString = stringFromHR
@@ -128,18 +133,11 @@ coAssert False msg   = coFail msg
 
 coOnFail :: IO a -> String -> IO a
-coOnFail io msg      = io 
-{- BEGIN_GHC_ONLY 
-    `Control.Exception.catch`
-    (\ err -> 
-       case Control.Exception.ioErrors err of
-         Just i  -> coFail (msg ++ ": " ++ (coGetErrorString i))
-	 Nothing -> coFail msg)
-   END_GHC_ONLY -}
-{- BEGIN_NOT_FOR_GHC -}
-    `IO.catch`
-    (\ err -> coFail (msg ++ ": " ++ (coGetErrorString err)))
-{- END_NOT_FOR_GHC -}
+coOnFail io msg      = catchComException io
+    (\ e -> 
+       case e of
+         Left  ioe -> coFail (msg ++ ": " ++ ioeGetErrorString ioe)
+	 Right ce  -> coFail (msg ++ ": " ++ comExceptionMsg ce))
 
 coFail :: String -> IO a
 coFail = coFailWithHR e_FAIL

System/Win32/Com/HDirect/HDirect.hs view

@@ -1,4 +1,4 @@-{-# OPTIONS -#include "PointerSrc.h" #-}
+{-# OPTIONS_GHC -XCPP -#include "PointerSrc.h" #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  System.Win32.Com.HDirect.HDirect
@@ -57,7 +57,6 @@ import Foreign.Marshal.Alloc (mallocBytes, free)
 
 import Data.Bits
-{- BEGIN_GHC_ONLY
 #if __GLASGOW_HASKELL__ >= 505
 import GHC.Base ( Int(..), Int#, getTag )
 #else
@@ -70,19 +69,12 @@            but has to be of kind *)
 -}
 #endif
-   END_GHC_ONLY -}
 
 infixl 5 .+.
 
-{- BEGIN_GHC_ONLY
 #if __GLASGOW_HASKELL__ >= 601
 foreignPtrToPtr = unsafeForeignPtrToPtr
 #endif
-   END_GHC_ONLY -}
-{- BEGIN_NOT_FOR_GHC -}
--- Versionitis. If your version of Hugs is troubled by this one, simply comment it out.
-foreignPtrToPtr = unsafeForeignPtrToPtr
-{- END_NOT_FOR_GHC -}
 
 {-
 At the moment the IDL compiler will emit calls to types with identity marshallers
@@ -165,19 +157,6 @@ readInt64 :: Ptr Int64 -> IO Int64
 writeInt64 ptr v = poke ptr v
 readInt64 ptr = peek ptr
-{-
-{- BEGIN_NOT_FOR_GHC -}
-writeInt64 ptr v = writeI64 ptr (fromIntegral lo) (fromIntegral hi)
- where
-   (hi,lo) = (fromIntegral v) `divMod` (toInteger (maxBound :: Int) + 1)
-readInt64 ptr = do
-  px <- readI64 ptr
-  lo <- peekElemOff px 0
-  hi <- peekElemOff px 1
-  free ptr
-  return (fromIntegral ((toInteger lo) + (toInteger hi) * (toInteger (maxBound :: Int) + 1)))
-{- END_NOT_FOR_GHC -}
--}
 
 sizeofInt64 :: Word32
 sizeofInt64 = fromIntegral (sizeOf (0 :: Int64))
@@ -329,14 +308,8 @@ 
 writeWord64 :: Ptr Word64 -> Word64 -> IO ()
 readWord64 :: Ptr Word64 -> IO Word64
-{- BEGIN_NOT_FOR_GHC -}
-writeWord64 _ _ = undefined
-readWord64 _ = undefined
-{- END_NOT_FOR_GHC -}
-{- BEGIN_GHC_ONLY
 writeWord64 p v = poke p v
 readWord64 p = peek p
-   END_GHC_ONLY -}
 
 sizeofWord64 :: Word32
 sizeofWord64 = fromIntegral (sizeOf (undefined :: Word64))
@@ -1054,8 +1027,6 @@ 	 writeString False pstr str
          f pstr
 
-{- BEGIN_GHC_ONLY
-
 enumToFlag :: Enum a => a -> Int
 enumToFlag tg = fromIntegral ((1::Word32) `shiftL` enumToInt tg)
 
@@ -1076,8 +1047,6 @@ 
 toIntFlag :: Int -> Int -> Int
 toIntFlag b v = fromIntegral ((1::Word32) `shiftL` (v + flagToIntTag b))
-
-   END_GHC_ONLY -}
 
 pow2Series :: Int -> Int32 -> [Int32]
 pow2Series len start = take len (iterate double start)

System/Win32/Com/HDirect/Pointer.hs view

@@ -47,30 +47,18 @@ type Finalizer a  = Ptr a -> IO ()  makeFO :: Ptr a -> FunPtr (Ptr a -> IO ()) -> IO (ForeignPtr b)-{- BEGIN_GHC_ONLY  #if __GLASGOW_HASKELL__ > 601 makeFO obj finaliser = newForeignPtr (mkFinal finaliser obj) obj >>= return.castForeignPtr #else makeFO obj finaliser = newForeignPtr obj (mkFinal finaliser obj) >>= return.castForeignPtr #endif-   END_GHC_ONLY -}-{- BEGIN_NOT_FOR_GHC -}--- Versionitis. If your version of Hugs is troubled by this one, simply enable the other version.-makeFO obj finaliser = newForeignPtr (mkFinal finaliser obj) obj >>= return.castForeignPtr---makeFO obj finaliser = newForeignPtr obj (mkFinal finaliser obj) >>= return.castForeignPtr-{- END_NOT_FOR_GHC -} -{- BEGIN_GHC_ONLY #if __GLASGOW_HASKELL__ < 505 mkFinal final obj = ap0 final obj foreign import ccall "dynamic" ap0 :: FunPtr (Ptr a -> IO()) -> (Ptr a -> IO ()) #else mkFinal final _ = final #endif-   END_GHC_ONLY -}-{- BEGIN_NOT_FOR_GHC -}-mkFinal final _ = final-{- END_NOT_FOR_GHC -}  --Helpers.

System/Win32/Com/HDirect/PointerPrim.hs view

@@ -1,4 +1,4 @@-{-# OPTIONS -#include "PointerSrc.h" #-}
+{-# OPTIONS_GHC -XCPP -fglasgow-exts -#include "PointerSrc.h" #-}
 -- Automatically generated by HaskellDirect (ihc.exe), snapshot 171208
 -- Created: 23:37 Pacific Standard Time, Wednesday 17 December, 2008
 -- Command line: -fno-qualified-names -fkeep-hresult -fout-pointers-are-not-refs -c System/Win32/Com/HDirect/PointerPrim.idl -o System/Win32/Com/HDirect/PointerPrim.hs

System/Win32/Com/HDirect/WideString.hs view

@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -XCPP -fglasgow-exts #-}
 {-# OPTIONS -#include <stdlib.h> #-}
 {-# OPTIONS -#include "WideStringSrc.h" #-}
 {-# OPTIONS -#include "PointerSrc.h" #-}

System/Win32/Com/Server.hs view

@@ -543,7 +543,7 @@ 	     -> IO HRESULT
 loadTypeInfo tlb_loc iid lcid ppITI = do
    (hr, pITypeLib) <- 
-    catch
+    catchComException
      (case tlb_loc of
         Left libid -> do
 	   ip <- loadRegTypeLib libid 1 0 (fromIntegral (primLangID lcid))

System/Win32/Com/Server/StdDispatch.hs view

@@ -394,7 +394,7 @@       let mkind = toMethodKind wFlags
           args  = unsafePerformIO (unmarshallArgs (castPtr pDispParams))
       st  <- getObjState this
-      catch (do
+      catchComException (do
         res <- dispMeth dispIdMember mkind args st
         case res of 
           Nothing -> do

com.cabal view

@@ -1,5 +1,5 @@ Name: com
-version: 1.1
+version: 1.2.0
 Synopsis: Haskell COM support library
 Description: 
     COM + Automation libraries for Haskell.
@@ -20,8 +20,12 @@           include/SafeArray.h
           include/StdTypes.h
 
+flag old-base
+  description: Old, monolithic base
+  default: False
+
 library {
-Build-depends: base, haskell98, old-time
+Build-depends: haskell98, old-time
 Exposed-Modules: System.Win32.Com,
                  System.Win32.Com.Base,
                  System.Win32.Com.Automation,
@@ -44,7 +48,6 @@                  System.Win32.Com.HDirect.PointerPrim,
                  System.Win32.Com.HDirect.WideString
                  
-Other-Modules:
 Include-dirs: . cbits include
 
 Includes: include/PointerSrc.h
@@ -69,5 +72,11 @@ -- relocatable object file.
 Ld-options: --enable-stdcall-fixup --disable-stdcall-fixup
 Extensions: CPP
-CPP-Options: -DFOR_GHC=1
+
+if flag(old-base)
+  Build-Depends: base < 4
+  CPP-Options: -DBASE=3
+else
+  Build-Depends: base >= 4
+  CPP-Options: -DBASE=4
 }

include/PointerSrc.h view

@@ -9,6 +9,7 @@ #define SUPPORT_COM 1
 #endif
 
+extern void   primNoFree(void* p);
 extern void   primPointerCheck();
 extern void   primFinalise(void* f, void* a);
 extern void*  primAllocMemory(int size);
@@ -22,6 +23,7 @@ extern void   primCoFreeMemory(void* p);
 extern void   primCoFreeBSTR(void* p);
 extern void*  finalCoFreeBSTR();
+extern void   primFreeBSTR( void* p );
 #endif
 
 #endif /* __POINTERSRC_H__ */