Menu
▾
▴
[hoc-cvs] [hoc commit] r383 - branches/objc2/hoc branches/objc2/hoc/HOC/HOC branches/objc2/hoc/HOC_cbits branches/objc2...
|
From: <cod...@go...> - 2009-01-10 01:59:43
|
Author: jam...@us...
Date: Fri Jan 9 17:57:45 2009
New Revision: 383
Modified:
/ (props changed)
branches/objc2/hoc/ (props changed)
branches/objc2/hoc/HOC.cabal
branches/objc2/hoc/HOC/HOC/Exception.hs
branches/objc2/hoc/HOC/HOC/NewClass.hs
branches/objc2/hoc/HOC/HOC/StdArgumentTypes.hs
branches/objc2/hoc/HOC_cbits/Ivars.h (props changed)
branches/objc2/hoc/HOC_cbits/Methods.h (props changed)
branches/objc2/hoc/InterfaceGenerator2/Headers.hs
branches/objc2/hoc/InterfaceGenerator2/ParserBase.hs
branches/objc2/hoc/Tests/MiniFoundation.hs
branches/objc2/hoc/Tests/TestFoundation.hs
Log:
merging trunk back to objc2 branch
Modified: branches/objc2/hoc/HOC.cabal
==============================================================================
--- branches/objc2/hoc/HOC.cabal (original)
+++ branches/objc2/hoc/HOC.cabal Fri Jan 9 17:57:45 2009
@@ -18,7 +18,7 @@
description: build for Objective-C 2.0
Library
- build-depends: base, template-haskell, unix
+ build-depends: base < 4, template-haskell, unix
exposed-modules:
HOC,
Modified: branches/objc2/hoc/HOC/HOC/Exception.hs
==============================================================================
--- branches/objc2/hoc/HOC/HOC/Exception.hs (original)
+++ branches/objc2/hoc/HOC/HOC/Exception.hs Fri Jan 9 17:57:45 2009
@@ -5,7 +5,7 @@
import Foreign
import Foreign.C.String ( CString, withCString )
import Prelude hiding ( catch )
-import Control.Exception ( evaluate, throwIO, throwDyn, catchDyn, catch
)
+import Control.Exception ( Exception, evaluate, throwIO, throwDyn,
catchDyn, catch )
import HOC.Base
import HOC.Arguments
@@ -15,8 +15,8 @@
deriving Typeable
-foreign import ccall unsafe wrapHaskellException :: CString -> StablePtr a
-> IO (Ptr ObjCObject)
-foreign import ccall unsafe unwrapHaskellException :: Ptr ObjCObject -> IO
(StablePtr a)
+foreign import ccall unsafe wrapHaskellException :: CString -> StablePtr
Exception -> IO (Ptr ObjCObject)
+foreign import ccall unsafe unwrapHaskellException :: Ptr ObjCObject -> IO
(StablePtr Exception)
exceptionObjCToHaskell :: Ptr ObjCObject -> IO a
Modified: branches/objc2/hoc/HOC/HOC/NewClass.hs
==============================================================================
--- branches/objc2/hoc/HOC/HOC/NewClass.hs (original)
+++ branches/objc2/hoc/HOC/HOC/NewClass.hs Fri Jan 9 17:57:45 2009
@@ -109,6 +109,8 @@
setHaskellReleaseMethod methodList idx super =
setMethodInList methodList idx releaseSelector "v@:" releaseCif
(haskellObject_release_IMP super)
+setHaskellReleaseMethod methodList idx =
+ setMethodInList methodList idx releaseSelector "v@:" releaseCif
haskellObject_release_IMP
setHaskellDataMethod methodList idx super mbDat =
setMethodInList methodList idx getHaskellDataSelector "^v@:#"
getHaskellDataCif (getHaskellData_IMP super mbDat)
Modified: branches/objc2/hoc/HOC/HOC/StdArgumentTypes.hs
==============================================================================
--- branches/objc2/hoc/HOC/HOC/StdArgumentTypes.hs (original)
+++ branches/objc2/hoc/HOC/HOC/StdArgumentTypes.hs Fri Jan 9 17:57:45 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
@@ -88,4 +98,4 @@
importArgument arg = nsStringToUTF8 arg >>= peekArray0 0
>>= return . utf8ToUnicode
- objCTypeString _ = "*"
+ objCTypeString _ = "@"
Modified: branches/objc2/hoc/InterfaceGenerator2/Headers.hs
==============================================================================
--- branches/objc2/hoc/InterfaceGenerator2/Headers.hs (original)
+++ branches/objc2/hoc/InterfaceGenerator2/Headers.hs Fri Jan 9 17:57:45
2009
@@ -12,7 +12,7 @@
import Control.Monad(when)
import Data.Char(isAlphaNum, toUpper)
import Data.List(isPrefixOf,isSuffixOf)
-import Data.Maybe(mapMaybe)
+import Data.Maybe(mapMaybe, maybeToList)
import System.Directory(getDirectoryContents, doesDirectoryExist)
import System.Info(os)
import Text.Parsec( runParserT )
@@ -89,9 +89,9 @@
graph :: Gr () ()
graph = mkUGraph [ 0 .. length loaded - 1 ]
[ (to, from) | (_, name, includes, _) <- loaded,
- from <- Map.lookup name
namesToNums,
+ from <- maybeToList $ Map.lookup
name namesToNums,
include <- includes,
- to <- Map.lookup include
namesToNums ]
+ to <- maybeToList $ Map.lookup
include namesToNums ]
sorted = map (numsToHeaders Map.!) $ topsort graph
process ( (headerFileName, moduleName, imports, contents) :
moreHeaders ) env accum
Modified: branches/objc2/hoc/InterfaceGenerator2/ParserBase.hs
==============================================================================
--- branches/objc2/hoc/InterfaceGenerator2/ParserBase.hs (original)
+++ branches/objc2/hoc/InterfaceGenerator2/ParserBase.hs Fri Jan 9
17:57:45 2009
@@ -21,7 +21,13 @@
= fst $ runMessages $ runParserT parser emptyParseEnvironment fileName
text
lookupIntegerConstant :: String -> Parser Integer
-lookupIntegerConstant name = getState >>= Map.lookup name
+lookupIntegerConstant name = getState >>= mapLookup name
+ where
+ -- ghc 6.10's containers package no longer allows arbitrary
+ -- monads in its return types
+ mapLookup k v = case Map.lookup k v of
+ Nothing -> fail "Integer constant not found"
+ Just x -> return x
defineIntegerConstant :: String -> Integer -> Parser ()
defineIntegerConstant name value = modifyState (Map.insert name value)
Modified: branches/objc2/hoc/Tests/MiniFoundation.hs
==============================================================================
--- branches/objc2/hoc/Tests/MiniFoundation.hs (original)
+++ branches/objc2/hoc/Tests/MiniFoundation.hs Fri Jan 9 17:57:45 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: branches/objc2/hoc/Tests/TestFoundation.hs
==============================================================================
--- branches/objc2/hoc/Tests/TestFoundation.hs (original)
+++ branches/objc2/hoc/Tests/TestFoundation.hs Fri Jan 9 17:57:45 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 [
|
