[hoc-cvs] [hoc commit] r382 - trunk/hoc/HOC/HOC trunk/hoc/Tests

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

Author: jam...@us...
Date: Fri Jan  9 17:28:12 2009
New Revision: 382

Modified:
    /   (props changed)
    trunk/hoc/HOC/HOC/StdArgumentTypes.hs
    trunk/hoc/Tests/MiniFoundation.hs
    trunk/hoc/Tests/TestFoundation.hs

Log:
Added an ObjCArgument instance for Maybe versions of all Ptr-marshalled  
types which maps nullPtr to Nothing.
Also added test cases for this and for something else I noticed a while  
back (not a bug in HOC, but a bug in some experiments I had been doing with  
ID marshalling).  It's somewhat redundant, but gives a good illustration of  
why certain other tests were failing in my experiments.


Modified: trunk/hoc/HOC/HOC/StdArgumentTypes.hs
==============================================================================
--- trunk/hoc/HOC/HOC/StdArgumentTypes.hs	(original)
+++ trunk/hoc/HOC/HOC/StdArgumentTypes.hs	Fri Jan  9 17:28:12 2009
@@ -78,6 +78,16 @@

  withUTF8String str = withArray0 0 (unicodeToUtf8 str)

+instance ObjCArgument a (Ptr b) => ObjCArgument (Maybe a) (Ptr b) where
+    withExportedArgument Nothing  action = action nullPtr
+    withExportedArgument (Just x) action = withExportedArgument x action
+    exportArgument Nothing  = return nullPtr
+    exportArgument (Just x) = exportArgument x
+    importArgument p
+        | p == nullPtr  = return Nothing
+        | otherwise     = fmap Just (importArgument p)
+    objCTypeString _ = objCTypeString (undefined :: a)
+
  instance ObjCArgument String (Ptr ObjCObject) where
      withExportedArgument arg action =
          bracket (withUTF8String arg utf8ToNSString) releaseObject action

Modified: trunk/hoc/Tests/MiniFoundation.hs
==============================================================================
--- trunk/hoc/Tests/MiniFoundation.hs	(original)
+++ trunk/hoc/Tests/MiniFoundation.hs	Fri Jan  9 17:28:12 2009
@@ -115,8 +115,10 @@
  -- NSMutableArray

  $(declareSelector "addObject:" [t| forall t1 . ID t1 -> IO () |])
+$(declareSelector "objectAtIndex:" [t| forall a. CUInt -> IO (ID a) |] )

  instance Has_addObject (NSMutableArray a)
+instance Has_objectAtIndex (NSMutableArray a)

  deriving instance Show NSRect
  deriving instance Show NSPoint

Modified: trunk/hoc/Tests/TestFoundation.hs
==============================================================================
--- trunk/hoc/Tests/TestFoundation.hs	(original)
+++ trunk/hoc/Tests/TestFoundation.hs	Fri Jan  9 17:28:12 2009
@@ -48,8 +48,15 @@
  instance Has_otherObject (HaskellObjectWithOutlet a)
  instance Has_setOtherObject (HaskellObjectWithOutlet a)

+$(declareSelector "maybeString" [t| IO (Maybe String) |])
+$(declareSelector "setMaybeString:" [t| Maybe String -> IO () |] )
+
+instance Has_maybeString (HaskellObjectWithOutlet a)
+instance Has_setMaybeString (HaskellObjectWithOutlet a)
+
  $(exportClass "HaskellObjectWithOutlet" "ho1_" [
-        Outlet "otherObject" [t| ID () |]
+        Outlet "otherObject" [t| ID () |],
+        Outlet "maybeString" [t| NSString () |]
      ])

  $(declareClass "HaskellObjectWithDescription" "NSObject")
@@ -214,6 +221,37 @@
                  hobj # setOtherObject num
                  num' <- hobj # otherObject >>= return . castObject
                  when (num /= num') $ assert "Different Object returned."
+            ),
+            "set-forget-reget" ~: (assertNoLeaks $ do
+                -- set an ivar, 'forget' the object (stash it outside  
haskell-space),
+                -- run the GC, 'remember' the object, and read the ivar.
+
+                -- this catches a class of bug which helped me grok  
HSOs ;-)
+
+                (num, array) <- assertLeaks 3 $ do
+                    num <- _NSNumber # alloc >>= initWithInt 42
+                    hobj <- _HaskellObjectWithOutlet # alloc >>= init
+                    hobj # setOtherObject num
+
+                    array <- _NSMutableArray # alloc >>= init
+                    array # addObject hobj
+
+                    return (num, array)
+
+                assertLeaks (-3) $ do
+                    hobj <- array # objectAtIndex 0 :: IO  
(HaskellObjectWithOutlet ())
+
+                    num' <- hobj # otherObject >>= return . castObject
+                    when (num /= num') $ assert "Different Object  
returned."
+            ),
+            "set-get-maybeString" ~: (assertNoLeaks $ do
+                hobj <- _HaskellObjectWithOutlet # alloc >>= init
+                nothing <- hobj # maybeString
+                nothing @?= Nothing
+
+                hobj # setMaybeString (Just "42")
+                just42 <- hobj # maybeString
+                just42 @?= Just "42"
              )
          ],
          "HaskellObjectWithIVar" ~: test [