[hoc-cvs] hoc/Tests Selectors.hs,NONE,1.1 TestFoundation.hs,1.5,1.6

[Wolfgang T. <wth...@us...>]

Update of /cvsroot/hoc/hoc/Tests
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv12043/Tests

Modified Files:
	TestFoundation.hs 
Added Files:
	Selectors.hs 
Log Message:
A monster commit, brought to you by the Greater Toronto Airport Authority
and Czech Airlines.

HOC now supports:

* Marshalling of exceptions
    NSExceptions get marshalled into Haskell exceptions that can be caught
    using Foundation.NSException.catchNS.
    Haskell exceptions get wrapped in a (private) subclass of NSException
    and marshalled back if they re-enter Haskell land.

* importing of extern constants
    $(declareExternConst "NSDeviceRGBColorSpace" [t| NSString () |])

* importing of global functions (e.g. NSRectFill) using HOC marshalling:
    $(declareExternFun "NSRectFill" [t| NSRect -> IO () |])

* ifgen generates constant & function declarations automatically from
  Foundation and AppKit headers.



Index: TestFoundation.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/Tests/TestFoundation.hs,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -d -r1.5 -r1.6
--- TestFoundation.hs	27 Jul 2005 02:36:09 -0000	1.5
+++ TestFoundation.hs	27 Sep 2005 11:55:22 -0000	1.6
@@ -10,6 +10,7 @@
 import Control.Monad        ( when )
 import Control.Exception    ( try, finally )
 
+import Selectors
 
       -- garbage collect and make really sure that finalizers have time to run
 performGCAndWait targetCount time maxRepeat = do
@@ -47,13 +48,30 @@
 $(declareClass "HaskellObjectWithDescription" "NSObject")
 
 $(exportClass "HaskellObjectWithDescription" "ho2_" [
-		InstanceMethod info_description
+        InstanceMethod info_description
     ])
-
+    
 ho2_description self
-	= do
-		superDesc <- fmap fromNSString $ super self # description
-		return $ toNSString $ head (words superDesc) ++ " TEST>"
+    = do
+        superDesc <- fmap fromNSString $ super self # description
+        return $ toNSString $ head (words superDesc) ++ " TEST>"
+
+$(declareClass "ExceptionThrower" "NSObject")
+
+instance Has_throwHaskellException (ExceptionThrower a)
+instance Has_throwNSException (ExceptionThrower a)
+
+$(exportClass "ExceptionThrower" "et_" [
+        InstanceMethod info_throwHaskellException,
+        InstanceMethod info_throwNSException
+    ])
+
+et_throwHaskellException self = fail "Test Exception"
+et_throwNSException self = _NSException # exceptionWithNameReasonUserInfo
+                                        (toNSString "FooBar")
+                                        (toNSString "baz")
+                                        nil
+                            >>= raise
 
 tests = test [
         "NSNumber" ~: test [
@@ -156,26 +174,55 @@
             )            
         ],
         "Super" ~: (assertNoLeaks $ do
-        	hobj <- _HaskellObjectWithDescription # alloc >>= init
-        	str <- hobj # description
-        	fromNSString str @?= "<HaskellObjectWithDescription: TEST>"
+            hobj <- _HaskellObjectWithDescription # alloc >>= init
+            str <- hobj # description
+            fromNSString str @?= "<HaskellObjectWithDescription: TEST>"
         ),
         "structs" ~: test [
-        	"point" ~: (do
-        		let point = NSPoint 6.42 7.42
-        		result <- _NSValue # valueWithPoint point >>= pointValue
-        		result @?= point
-        	),
-        	"size" ~: (do
-        		let size = NSSize 6.42 7.42
-        		result <- _NSValue # valueWithSize size >>= sizeValue
-        		result @?= size
-        	),
-			"rect" ~: (do
-        		let rect = NSRect (NSPoint 1 2) (NSSize 3 4)
-        		result <- _NSValue # valueWithRect rect >>= rectValue
-        		result @?= rect
-        	)
+            "point" ~: (do
+                let point = NSPoint 6.42 7.42
+                result <- _NSValue # valueWithPoint point >>= pointValue
+                result @?= point
+            ),
+            "size" ~: (do
+                let size = NSSize 6.42 7.42
+                result <- _NSValue # valueWithSize size >>= sizeValue
+                result @?= size
+            ),
+            "rect" ~: (do
+                let rect = NSRect (NSPoint 1 2) (NSSize 3 4)
+                result <- _NSValue # valueWithRect rect >>= rectValue
+                result @?= rect
+            )
+        ],
+        "externConstant" ~: (
+            fromNSString nsParseErrorException @?= "NSParseErrorException"
+        ),
+        "externFunction" ~: (do
+            result <- nsStringFromPoint (NSPoint 42 23)
+            fromNSString result @?= "{42, 23}"
+        ),
+        "exceptions" ~: test [
+            "CtoH" ~: (do
+                exc1 <- _NSException # exceptionWithNameReasonUserInfo
+                                        (toNSString "FooBar")
+                                        (toNSString "baz")
+                                        nil
+                result <- (exc1 # raise >> return "No Exception")
+                        `catchNS` \e -> e # name >>= return . fromNSString 
+                result @?= "FooBar"
+            ),
+            "HtoCtoH" ~: (do
+                obj <- _ExceptionThrower # alloc >>= init
+                result <- try (obj # throwHaskellException)
+                show result @?= "Left user error (Test Exception)"
+            ),
+            "CtoHtoCtoH" ~: (do
+                obj <- _ExceptionThrower # alloc >>= init
+                result <- (obj # throwNSException >> return "No Exception")
+                        `catchNS` \e -> e # name >>= return . fromNSString 
+                result @?= "FooBar"
+            )
         ]
     ]
 
@@ -184,4 +231,5 @@
 main = do
     initializeClass_HaskellObjectWithOutlet
     initializeClass_HaskellObjectWithDescription
+    initializeClass_ExceptionThrower
     go

--- NEW FILE: Selectors.hs ---
module Selectors where

import HOC

$(declareSelector "throwHaskellException" [t| IO () |])
$(declareSelector "throwNSException" [t| IO () |])