[hoc-cvs] hoc/HOC/HOC Arguments.hs, 1.6, 1.7 DeclareSelector.hs, 1.13, 1.14 ExportClass.hs, 1.10, 1.11 ID.hs, 1.9, 1.10 Invocation.hs, 1.2, 1.3 NewlyAllocated.hs, 1.4, 1.5 SelectorMarshaller.hs, 1.10, 1.11 Super.hs, 1.2, 1.3 Utilities.hs, 1.1.1.1, 1.2

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

Update of /cvsroot/hoc/hoc/HOC/HOC
In directory sc8-pr-cvs5.sourceforge.net:/tmp/cvs-serv6881/HOC/HOC

Modified Files:
	Arguments.hs DeclareSelector.hs ExportClass.hs ID.hs 
	Invocation.hs NewlyAllocated.hs SelectorMarshaller.hs Super.hs 
	Utilities.hs 
Log Message:
a) Utilities cleanup:
	remove #* (send message and release result)
	add #. (get instance variable)
	add declareMarshalledObjectType
b) sending init messages to super is now supported
c) can now implement methods that return a retained object (like init)



Index: ID.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/HOC/HOC/ID.hs,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -d -r1.9 -r1.10
--- ID.hs	27 Jul 2005 02:36:09 -0000	1.9
+++ ID.hs	13 Feb 2007 17:11:04 -0000	1.10
@@ -136,6 +136,12 @@
         return arg
     exportArgument Nil = return nullPtr
     
+    exportArgumentRetained (ID thing@(HSO arg _)) = do
+        retainObject arg
+        evaluate thing  -- make sure the HSO has been alive until now
+        return arg
+    exportArgumentRetained Nil = return nullPtr
+    
     importArgument = importArgument' False
     
     objCTypeString _ = "@"

Index: ExportClass.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/HOC/HOC/ExportClass.hs,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -d -r1.10 -r1.11
--- ExportClass.hs	20 Mar 2006 06:25:26 -0000	1.10
+++ ExportClass.hs	13 Feb 2007 17:11:04 -0000	1.11
@@ -174,6 +174,7 @@
                 
                 exportMethod' isClassMethod objCMethodList num methodBody
                               nArgs isUnit impTypeName selExpr cifExpr
+                              retainedExpr
             where
                 methodBody = varE $ mkName $ prefix ++ nameBase selName
                 
@@ -186,6 +187,7 @@
                 
                 selExpr = [| selectorInfoSel $(varE $ infoName) |]
                 cifExpr = [| selectorInfoCif $(varE $ infoName) |]
+                retainedExpr = [| selectorInfoResultRetained $(varE $ infoName) |]
         
         exportMethod isClassMethod objCMethodList (GetterMethod ivarName, num) =
                 exportMethod' isClassMethod objCMethodList num
@@ -193,6 +195,7 @@
                               0 False (''GetVarImpType)
                               [| getSelectorForName ivarName |]
                               [| getVarCif |]
+                              [| False |]
             
         exportMethod isClassMethod objCMethodList (SetterMethod ivarName, num) =
                 exportMethod' isClassMethod objCMethodList num
@@ -200,6 +203,7 @@
                               1 True (''SetVarImpType)
                               [| getSelectorForName setterName |]
                               [| setVarCif |]
+                              [| False |]
             where
                 setterName = setterNameFor ivarName
         
@@ -208,7 +212,7 @@
             
                 
         exportMethod' isClassMethod objCMethodList num methodBody
-                       nArgs isUnit impTypeName selExpr cifExpr =
+                       nArgs isUnit impTypeName selExpr cifExpr retainedExpr =
             [|
                 setMethodInList $(objCMethodList)
                                 num
@@ -218,24 +222,29 @@
                                 ($(lamE (map (varP.mkName) ["cif","ret","args"]) marshal))
             |]
             where
-                marshal = [| exceptionHaskellToObjC $(marshal') |]
+                marshal = [| do recordHOCEvent kHOCEnteredHaskell $(varE $ mkName "args")
+                                exc <- exceptionHaskellToObjC $(marshal')
+                                recordHOCEvent kHOCAboutToLeaveHaskell $(varE $ mkName "args")
+                                return exc
+                          |]
                 marshal' = doE $ getArg ("self",0)
                                  : map getArg (zip arguments [2..])
-                                 ++ invokeAndReturn
+                                 ++ [
+                                    noBindS [| recordHOCEvent kHOCImportedArguments $(varE $ mkName "args") |],
+                                    noBindS invokeAndReturn
+                                 ]
                 
                 
                 arguments = [ "arg" ++ show i | i <- [1..nArgs] ]
                 
                 invokeAndReturn
                     | isUnit =
-                        [noBindS typedBodyWithArgs]
+                        typedBodyWithArgs
                     | otherwise =
-                        [
-                            bindS (varP $ mkName "result") typedBodyWithArgs,
-                            noBindS [| setMarshalledRetval
-                                            $(varE $ mkName "ret")
-                                            $(varE $ mkName "result") |]
-                        ]
+                        [| do result <- $(typedBodyWithArgs)
+                              recordHOCEvent kHOCAboutToExportResult $(varE $ mkName "args")
+                              setMarshalledRetval $(retainedExpr) $(varE $ mkName "ret") result
+                        |]
                 
                 typedBodyWithArgs = foldl1 appE (typed methodBody
                                                 : map (varE.mkName)(arguments ++ ["self"])) 

Index: Super.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/HOC/HOC/Super.hs,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -d -r1.2 -r1.3
--- Super.hs	27 Jul 2005 02:36:09 -0000	1.2
+++ Super.hs	13 Feb 2007 17:11:04 -0000	1.3
@@ -1,5 +1,6 @@
+{-# OPTIONS -fallow-undecidable-instances #-}
 module HOC.Super(
-        SuperClass, SuperTarget, super
+        SuperClass, SuperTarget, Super(super), withExportedSuper
     ) where
 
 import HOC.Base
@@ -20,29 +21,34 @@
 
 data SuperTarget a = SuperTarget a
 
-super :: (Object sub, Object super, SuperClass sub super)
-      => sub -> SuperTarget super
+class Super sub super | sub -> super where
+    super :: sub -> super
 
 --- 
 
 pokeSuper objcSuper obj cls
     = pokeByteOff objcSuper 0 obj >> pokeByteOff objcSuper (sizeOf obj) cls
 
+withExportedSuper p action = 
+    getSuperClassForObject p >>= \cls ->
+    allocaBytes (sizeOf p + sizeOf cls) $ \sptr ->
+    pokeSuper sptr p cls >> action sptr
+
 instance MessageTarget a
         => ObjCArgument (SuperTarget a) (Ptr ObjCObject) where
 
     withExportedArgument (SuperTarget obj) action =
         withExportedArgument obj $ \p ->
-        getSuperClassForObject p >>= \cls ->
-        allocaBytes (sizeOf p + sizeOf cls) $ \sptr ->
-        pokeSuper sptr p cls >> action sptr
+        withExportedSuper p action
         
     exportArgument _ = fail "HOC.Super: exportArgument"
     importArgument _ = fail "HOC.Super: importArgument"
 
     objCTypeString _ = "@"      -- well, close enough.
 
-super obj = SuperTarget (fromID $ toID obj)
+instance (Object (ID sub), Object super, SuperClass (ID sub) super)
+    => Super (ID sub) (SuperTarget super) where
+    super obj = SuperTarget (fromID $ toID obj)
 
 getSuperClassForObject obj = do cls <- peekByteOff obj 0 :: IO (Ptr (Ptr ()))
                                 peekElemOff cls 1

Index: Arguments.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/HOC/HOC/Arguments.hs,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -d -r1.6 -r1.7
--- Arguments.hs	17 Mar 2006 04:57:37 -0000	1.6
+++ Arguments.hs	13 Feb 2007 17:11:04 -0000	1.7
@@ -15,11 +15,14 @@
 class (Storable b, FFITypeable b) => ObjCArgument a b | a -> b where
     withExportedArgument :: a -> (b -> IO c) -> IO c
     exportArgument :: a -> IO b
+    exportArgumentRetained :: a -> IO b
     importArgument :: b -> IO a
     
     objCTypeString :: a -> String
     
     withExportedArgument arg action = exportArgument arg >>= action
+    
+    exportArgumentRetained = exportArgument
 {-
     For types that are Storable & FFITypeable, define
     

Index: SelectorMarshaller.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/HOC/HOC/SelectorMarshaller.hs,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -d -r1.10 -r1.11
--- SelectorMarshaller.hs	26 Jul 2005 05:23:48 -0000	1.10
+++ SelectorMarshaller.hs	13 Feb 2007 17:11:04 -0000	1.11
@@ -1,6 +1,7 @@
 module HOC.SelectorMarshaller(
         SelectorInfo(..),
         mkSelectorInfo,
+        mkSelectorInfoRetained,
         makeMarshaller,
         makeMarshallers,
         marshallerName
@@ -25,17 +26,18 @@
         selectorInfoObjCName :: String,
         selectorInfoHaskellName :: String,
         selectorInfoCif :: !FFICif,
-        selectorInfoSel :: !SEL
+        selectorInfoSel :: !SEL,
+        selectorInfoResultRetained :: !Bool
     }
 
 {-# NOINLINE mkSelectorInfo #-}
 mkSelectorInfo objCName hsName cif
-	= SelectorInfo objCName hsName cif (getSelectorForName objCName)
+	= SelectorInfo objCName hsName cif (getSelectorForName objCName) False
 
 {-# NOINLINE mkSelectorInfo# #-}
 mkSelectorInfo# objCName# hsName# cif
 	-- NOTE: Don't call mkSelectorInfo here, the rule would apply!
-	= SelectorInfo objCName hsName cif (getSelectorForName objCName)
+	= SelectorInfo objCName hsName cif (getSelectorForName objCName) False
 	where
 		objCName = unpackCString# objCName#
 		hsName   = unpackCString# hsName#
@@ -46,6 +48,25 @@
 	= mkSelectorInfo# s1 s2 cif
   #-}
 
+{-# NOINLINE mkSelectorInfoRetained #-}
+mkSelectorInfoRetained objCName hsName cif
+	= SelectorInfo objCName hsName cif (getSelectorForName objCName) True
+
+{-# NOINLINE mkSelectorInfoRetained# #-}
+mkSelectorInfoRetained# objCName# hsName# cif
+	-- NOTE: Don't call mkSelectorInfo here, the rule would apply!
+	= SelectorInfo objCName hsName cif (getSelectorForName objCName) True
+	where
+		objCName = unpackCString# objCName#
+		hsName   = unpackCString# hsName#
+
+{-# RULES
+"litstr" forall s1 s2 cif.
+	mkSelectorInfoRetained (unpackCString# s1) (unpackCString# s2) cif
+	= mkSelectorInfoRetained# s1 s2 cif
+  #-}
+
+
 makeMarshaller maybeInfoName haskellName nArgs isUnit isPure isRetained =
             funD haskellName [
                 clause (map varP $ infoArgument ++ map mkName arguments

Index: DeclareSelector.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/HOC/HOC/DeclareSelector.hs,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -d -r1.13 -r1.14
--- DeclareSelector.hs	1 Nov 2006 15:45:04 -0000	1.13
+++ DeclareSelector.hs	13 Feb 2007 17:11:04 -0000	1.14
@@ -164,14 +164,17 @@
 
 
             makeImpType ty = replaceResult (
-                                (ArrowT `AppT` VarT (mkName "target"))
+                                (ArrowT `AppT` fromMaybe (VarT $ mkName "target") target')
                                 `AppT` covariantResult
                             ) ty'
                 where
                     ty' = simplifyType ty
-                    (_retained, _needInstance, _target', covariantResult) =
+                    (_retained, _needInstance, target', covariantResult) =
                         doctorCovariant $ resultType ty'
-        
+            
+            selInfoMaker | resultRetained = [| mkSelectorInfoRetained |]
+                         | otherwise      = [| mkSelectorInfo |]
+            
         sequence $ [
                 
                 -- $(selectorName) = getSelectorForName "name"
@@ -183,7 +186,7 @@
                     in valD (varP $ mkName $ infoName) (normalB
                         [|
                         	let n = $(stringE name)
-                        	in mkSelectorInfo n
+                        	in $(selInfoMaker) n
                                                 $(if haskellName == name
                                                         then [|n|]
                                                         else stringE haskellName)

Index: Utilities.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/HOC/HOC/Utilities.hs,v
retrieving revision 1.1.1.1
retrieving revision 1.2
diff -u -d -r1.1.1.1 -r1.2
--- Utilities.hs	27 Oct 2003 16:48:10 -0000	1.1.1.1
+++ Utilities.hs	13 Feb 2007 17:11:04 -0000	1.2
@@ -2,6 +2,43 @@
 
 import HOC.Base
 import HOC.Arguments
+import HOC.ID
+import HOC.TH
+import HOC.ExportClass
+import Foreign.Ptr
 
 x # f = f x
-obj #* msg = obj # msg >>= \newObj -> withExportedArgument newObj releaseObject >> return newObj
+
+x #. v = x # getIVar v
+
+declareMarshalledObjectType ty
+    = do
+        (context, ty') <- splitTy ty
+        argInst <- instanceD context (conT ''ObjCArgument
+            `appT` ty' `appT` [t| Ptr ObjCObject |])
+                `whereQ` valDs [
+                    ('withExportedArgument,   [| withExportedArgument   . toID |]),
+                    ('exportArgument,         [| exportArgument         . toID |]),
+                    ('exportArgumentRetained, [| exportArgumentRetained . toID |]),
+                    ('importArgument,         [| fmap fromID . importArgument    |]),
+                    ('objCTypeString,         [| objCTypeString         . toID |])
+                ]
+        msgTarget <- instanceD context (conT ''MessageTarget
+            `appT` ty')
+                `whereQ` valDs [
+                    ('isNil, [| \_ -> False |]),
+                    ('sendMessageWithRetval,    [| sendMessageWithRetval    . toID |]),
+                    ('sendMessageWithoutRetval, [| sendMessageWithoutRetval . toID |])
+                ]
+        return [argInst, msgTarget]
+    where
+        valDs decls
+            = sequence [
+                do e <- b ; return (ValD (VarP n) (NormalB e) [])
+                | (n, b) <- decls
+            ]
+        
+        splitTy ty = do t <- ty
+                        return $ case t of
+                            (ForallT ns context t') -> (return context, return t')
+                            other                   -> (cxt [], ty)
\ No newline at end of file

Index: NewlyAllocated.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/HOC/HOC/NewlyAllocated.hs,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -d -r1.4 -r1.5
--- NewlyAllocated.hs	27 Jul 2005 02:36:09 -0000	1.4
+++ NewlyAllocated.hs	13 Feb 2007 17:11:04 -0000	1.5
@@ -1,3 +1,4 @@
+{-# OPTIONS -fallow-undecidable-instances #-}
 module HOC.NewlyAllocated where
 
 {-
@@ -15,15 +16,24 @@
 import HOC.Arguments    ( ObjCArgument(..) )
 import HOC.ID           ( Object(..), MessageTarget(..) )
 import HOC.MsgSend
+import HOC.Super
 
 import Foreign.Ptr      ( Ptr, nullPtr )
 import System.IO.Unsafe ( unsafePerformIO )
 
-newtype NewlyAllocated a = NewlyAllocated (Ptr ObjCObject)
+
+data NewlyAllocated a
+    = NewlyAllocated (Ptr ObjCObject)
+    | NewSuper (Ptr ObjCObject)
 
 instance ObjCArgument (NewlyAllocated a) (Ptr ObjCObject) where
     withExportedArgument (NewlyAllocated p) action = action p
+    withExportedArgument (NewSuper p) action =
+        withExportedSuper p action
+    
     exportArgument (NewlyAllocated p) = return p
+    exportArgument (NewSuper p) = fail "HOC.NewlyAllocated.NewSuper: exportArgument"
+    
     importArgument p = return (NewlyAllocated p)
 
     objCTypeString _ = "@"
@@ -35,6 +45,13 @@
     
 instance MessageTarget (NewlyAllocated a) where
     isNil (NewlyAllocated p) = p == nullPtr
+    isNil (NewSuper p) = p == nullPtr
 
-    sendMessageWithRetval _ = objSendMessageWithRetval
-    sendMessageWithoutRetval _ = objSendMessageWithoutRetval
+    sendMessageWithRetval (NewlyAllocated _) = objSendMessageWithRetval
+    sendMessageWithRetval (NewSuper _) = superSendMessageWithRetval
+    sendMessageWithoutRetval (NewlyAllocated _) = objSendMessageWithoutRetval
+    sendMessageWithoutRetval (NewSuper _) = superSendMessageWithoutRetval
+
+instance SuperClass sub super
+    => Super (NewlyAllocated sub) (NewlyAllocated super) where
+    super (NewlyAllocated x) = NewSuper x

Index: Invocation.hs
===================================================================
RCS file: /cvsroot/hoc/hoc/HOC/HOC/Invocation.hs,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -d -r1.2 -r1.3
--- Invocation.hs	27 Sep 2005 11:55:22 -0000	1.2
+++ Invocation.hs	13 Feb 2007 17:11:04 -0000	1.3
@@ -1,6 +1,7 @@
 module HOC.Invocation where
 
 import Foreign
+import Foreign.C            ( CInt )
 import Control.Monad        ( when )
 
 import HOC.Base
@@ -42,12 +43,23 @@
         >> peek retptr >>= importArgument
 
 
-setMarshalledRetval :: ObjCArgument a b => Ptr () -> a -> IO ()
-setMarshalledRetval ptr val =
-    exportArgument val >>= poke (castPtr ptr)
+setMarshalledRetval :: ObjCArgument a b => Bool -> Ptr () -> a -> IO ()
+setMarshalledRetval retained ptr val =
+    (if retained then exportArgumentRetained else exportArgument) val
+        >>= poke (castPtr ptr)
 
 getMarshalledArgument :: ObjCArgument a b => Ptr (Ptr ()) -> Int -> IO a
 getMarshalledArgument args idx = do
     p <- peekElemOff args idx
     arg <- peek (castPtr p)
     importArgument arg
+    
+    
+foreign import ccall unsafe recordHOCEvent :: CInt -> Ptr (Ptr ()) -> IO ()
+
+kHOCEnteredHaskell = 1 :: CInt
+kHOCImportedArguments = 2 :: CInt
+kHOCAboutToExportResult = 3 :: CInt
+kHOCAboutToLeaveHaskell = 4 :: CInt
+
+