[hoc-cvs] [hoc commit] r386 - in trunk/hoc: . Bindings/AdditionalCode/Foundation HOC/HOC InterfaceGenerator2 Tests

[<cod...@go...>]

Author: wol...@gm...
Date: Sat Feb 14 12:53:11 2009
New Revision: 386

Modified:
    trunk/hoc/Bindings/AdditionalCode/Foundation/NSException.hs
    trunk/hoc/HOC.cabal
    trunk/hoc/HOC/HOC/Exception.hs
    trunk/hoc/InterfaceGenerator2/Output.hs
    trunk/hoc/Tests/MiniFoundation.hs
    trunk/hoc/Tests/TestFoundation.hs

Log:
add a flag for base 4.0 support


Modified: trunk/hoc/Bindings/AdditionalCode/Foundation/NSException.hs
==============================================================================
--- trunk/hoc/Bindings/AdditionalCode/Foundation/NSException.hs	(original)
+++ trunk/hoc/Bindings/AdditionalCode/Foundation/NSException.hs	Sat Feb 14  
12:53:11 2009
@@ -1,10 +1,9 @@
  --X catchNS

-import Control.Exception    ( catchDyn )
-import HOC.Exception        ( WrappedNSException(..) )
+import HOC.Exception        ( WrappedNSException(..),  
catchWrappedNSException )
  -- CUT HERE

  catchNS :: IO a -> (NSException () -> IO a) -> IO a

  catchNS action handler
-    = action `catchDyn` \(WrappedNSException exc) -> handler (castObject  
exc)
+    = action `catchWrappedNSException` \(WrappedNSException exc) ->  
handler (castObject exc)

Modified: trunk/hoc/HOC.cabal
==============================================================================
--- trunk/hoc/HOC.cabal	(original)
+++ trunk/hoc/HOC.cabal	Sat Feb 14 12:53:11 2009
@@ -17,8 +17,15 @@
  Flag ObjC2
      description: build for Objective-C 2.0

+Flag base4
+
  Library
-    build-depends: base < 4, template-haskell, unix
+    build-depends: template-haskell, unix
+    if flag(base4)
+        build-depends: base >= 4, syb
+        cpp-options: -DBASE4
+    else
+        build-depends: base < 4

      exposed-modules:
          HOC,
@@ -87,7 +94,12 @@

      cpp-options: -DTEST

-    build-depends: HUnit
+    build-depends: HUnit, template-haskell, unix
+    if flag(base4)
+        build-depends: base >= 4, syb
+        cpp-options: -DBASE4
+    else
+        build-depends: base < 4

      if !flag(Tests)
          buildable: False

Modified: trunk/hoc/HOC/HOC/Exception.hs
==============================================================================
--- trunk/hoc/HOC/HOC/Exception.hs	(original)
+++ trunk/hoc/HOC/HOC/Exception.hs	Sat Feb 14 12:53:11 2009
@@ -1,11 +1,12 @@
-{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable #-}
+{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable,
+             ScopedTypeVariables, CPP #-}
  module HOC.Exception where

  import Data.Typeable
  import Foreign
  import Foreign.C.String     ( CString, withCString )
  import Prelude              hiding ( catch )
-import Control.Exception    ( Exception, evaluate, throwIO, throwDyn,  
catchDyn, catch )
+import Control.Exception

  import HOC.Base
  import HOC.Arguments
@@ -14,11 +15,53 @@
  data WrappedNSException = WrappedNSException (ID ())
      deriving Typeable

+exceptionObjCToHaskell :: Ptr ObjCObject -> IO a

-foreign import ccall unsafe wrapHaskellException :: CString -> StablePtr  
Exception -> IO (Ptr ObjCObject)
-foreign import ccall unsafe unwrapHaskellException :: Ptr ObjCObject -> IO  
(StablePtr Exception)
+#ifdef BASE4

-exceptionObjCToHaskell :: Ptr ObjCObject -> IO a
+foreign import ccall unsafe wrapHaskellException
+    :: CString -> StablePtr SomeException -> IO (Ptr ObjCObject)
+foreign import ccall unsafe unwrapHaskellException
+    :: Ptr ObjCObject -> IO (StablePtr SomeException)
+
+-- get the exception pointer figure out if it is a NSException
+-- or a haskell exception and throw it.
+exceptionObjCToHaskell exception = do
+    sptr <- unwrapHaskellException exception
+    if (castStablePtrToPtr sptr == nullPtr)
+        then do
+            exc <- importArgument exception
+            throwIO $ WrappedNSException exc
+        else do
+            exc <- deRefStablePtr sptr
+            throwIO exc
+
+exceptionHaskellToObjC :: IO a -> IO (Ptr ObjCObject)
+
+exceptionHaskellToObjC action =
+    (action >> return nullPtr)
+        `catches` [
+            Handler $ \(WrappedNSException exc) -> exportArgument exc,
+            Handler $ \(exc :: SomeException) -> withCString (show exc) $
+                \cstr -> newStablePtr exc >>= wrapHaskellException cstr
+        ]
+
+instance Exception WrappedNSException where
+    toException = SomeException
+    fromException (SomeException ex) = cast ex
+
+instance Show WrappedNSException where
+    show (WrappedNSException ex) = "<<NSException>>"
+
+catchWrappedNSException :: IO a -> (WrappedNSException -> IO a) -> IO a
+catchWrappedNSException = catch
+
+#else
+
+foreign import ccall unsafe wrapHaskellException
+    :: CString -> StablePtr Exception -> IO (Ptr ObjCObject)
+foreign import ccall unsafe unwrapHaskellException
+    :: Ptr ObjCObject -> IO (StablePtr Exception)

  -- get the exception pointer figure out if it is a NSException
  -- or a haskell exception and throw it.
@@ -40,3 +83,8 @@
      (\(WrappedNSException exc) -> exportArgument exc)
          `catch`
      (\exc -> withCString (show exc) $ \cstr -> newStablePtr exc >>=  
wrapHaskellException cstr)
+
+catchWrappedNSException :: IO a -> (WrappedNSException -> IO a) -> IO a
+catchWrappedNSException = catchDyn
+
+#endif

Modified: trunk/hoc/InterfaceGenerator2/Output.hs
==============================================================================
--- trunk/hoc/InterfaceGenerator2/Output.hs	(original)
+++ trunk/hoc/InterfaceGenerator2/Output.hs	Sat Feb 14 12:53:11 2009
@@ -290,13 +290,21 @@
      = text "name:" <+> text "HOC-" <> text frameworkName $+$
        text "version: 1.0" $+$
        text "build-type: Simple" $+$
-      text "build-depends:" <+>
-        hsep (punctuate comma $ map text $
-                ["base <4", "HOC"] ++ map ("HOC-" ++) dependencies) $+$
---      text "" $+$
-      text "exposed-modules:" <+> sep (punctuate comma $
-                                        map textBS $ BS.pack  
frameworkName : modules) $+$
-      text "frameworks:" <+> text frameworkName
+      text "Flag base" $+$
+      text "Library" $+$ nest 4 (
+          text "if flag(base4)" $+$ nest 4 (
+              text "build-depends: base >= 4" $+$
+              text "cpp-options: -DBASE4" -- don't neeed the define yet,  
though
+          ) $+$ text "else" $+$ nest 4 (
+              text "build-depends: base < 4"
+          ) $+$
+          text "build-depends:" <+>
+              hsep (punctuate comma $ map text $
+                    ["HOC"] ++ map ("HOC-" ++) dependencies) $+$
+          text "exposed-modules:" <+> sep (punctuate comma $
+                                            map textBS $ BS.pack  
frameworkName : modules) $+$
+          text "frameworks:" <+> text frameworkName
+      )
      where
          modules = [ m | LocalModule m
                     <- Set.toList $ Set.fromList $

Modified: trunk/hoc/Tests/MiniFoundation.hs
==============================================================================
--- trunk/hoc/Tests/MiniFoundation.hs	(original)
+++ trunk/hoc/Tests/MiniFoundation.hs	Sat Feb 14 12:53:11 2009
@@ -1,13 +1,14 @@
  {-# LANGUAGE TemplateHaskell, StandaloneDeriving, MultiParamTypeClasses,
-             TypeSynonymInstances, FlexibleInstances, RankNTypes #-}
+             TypeSynonymInstances, FlexibleInstances, RankNTypes, CPP #-}
  module MiniFoundation where

  import HOC
  import HOC.Exception        ( WrappedNSException(..) )

  import Foreign.C.Types
-import Control.Exception    ( catchDyn )
+import Control.Exception
  import System.IO.Unsafe     ( unsafePerformIO )
+import Prelude hiding ( catch )

  $(declareClass "NSObject" "ID")
  $(declareClass "NSString" "NSObject")
@@ -109,8 +110,13 @@

  catchNS :: IO a -> (NSException () -> IO a) -> IO a

+#ifdef BASE4
+catchNS action handler
+    = action `catch` \(WrappedNSException exc) -> handler (castObject exc)
+#else
  catchNS action handler
      = action `catchDyn` \(WrappedNSException exc) -> handler (castObject  
exc)
+#endif

  -- NSMutableArray


Modified: trunk/hoc/Tests/TestFoundation.hs
==============================================================================
--- trunk/hoc/Tests/TestFoundation.hs	(original)
+++ trunk/hoc/Tests/TestFoundation.hs	Sat Feb 14 12:53:11 2009
@@ -1,4 +1,5 @@
-{-# OPTIONS -fth -fglasgow-exts #-}
+{-# LANGUAGE TemplateHaskell, TypeSynonymInstances, FlexibleInstances,
+             MultiParamTypeClasses, RankNTypes, DeriveDataTypeable, CPP #-}
  module TestFoundation where

  import HOC
@@ -13,7 +14,7 @@
  import System.Mem           ( performGC )
  import Control.Concurrent   ( threadDelay )
  import Control.Monad        ( when )
-import Control.Exception    ( try, finally, catchDyn )
+import Control.Exception hiding ( assert )
  import qualified System.Info( os )


@@ -300,7 +301,12 @@
                  let nilNumber = nil :: NSNumber ()
                  result <- try (nilNumber # intValue)
                  expected <- try (fail "Message sent to nil: intValue")
+#ifdef BASE4
+                show (result :: Either SomeException CInt)
+                    @?= show (expected :: Either SomeException CInt)
+#else
                  result @?= expected
+#endif
              )
          ],
          "Super" ~: test [
@@ -385,7 +391,12 @@
              "HtoCtoH" ~: (do
                  obj <- _ExceptionThrower # alloc >>= init
                  result <- try (obj # throwHaskellException)
+#ifdef BASE4
+                show (result :: Either SomeException ())
+                    @?= "Left user error (Test Exception)"
+#else
                  show result @?= "Left user error (Test Exception)"
+#endif
              ),
              "CtoHtoCtoH" ~: (do
                  obj <- _ExceptionThrower # alloc >>= init