[hoc-cvs] [hoc commit] r374 - in branches/objc2/hoc: HOC HOC/HOC Tests

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

Author: jam...@us...
Date: Wed Dec 10 07:59:54 2008
New Revision: 374

Modified:
    branches/objc2/hoc/HOC/HOC.hs
    branches/objc2/hoc/HOC/HOC/Class.hs
    branches/objc2/hoc/HOC/HOC/DeclareClass.hs
    branches/objc2/hoc/Tests/TestFoundation.hs

Log:
Experimental patch (committed to objc2 branch only for now, though it's not  
at all specific to objective c 2.0 - I just wasn't sure if it was too  
disruptive to push to the trunk) extending previous work on super calls to  
cover class methods.

This involved adding a fair bit to the output of declareClass - if anyone  
sees a better way to do this, I'd love to hear about it.  One thing I  
thought about was using an instance of the form:

instance ClassAndObject meta $(metaClsType) => ClassObject meta
	where classObject = unsafeGetMetaclassForClass classObject

	I believe this would have "worked" with slightly less clutter in the  
namespace, but it would require adding FlexibleContexts to the LANGUAGE  
pragma
of every source file that calls declareClass, which seemed even more  
disruptive.


Modified: branches/objc2/hoc/HOC/HOC.hs
==============================================================================
--- branches/objc2/hoc/HOC/HOC.hs	(original)
+++ branches/objc2/hoc/HOC/HOC.hs	Wed Dec 10 07:59:54 2008
@@ -4,6 +4,7 @@
          nil,
          Object(..),
          Class,
+        MetaClass,
          ClassAndObject,
          ClassObject,
          classObject,

Modified: branches/objc2/hoc/HOC/HOC/Class.hs
==============================================================================
--- branches/objc2/hoc/HOC/HOC/Class.hs	(original)
+++ branches/objc2/hoc/HOC/HOC/Class.hs	Wed Dec 10 07:59:54 2008
@@ -11,15 +11,13 @@
  import Foreign
  import Foreign.C.String

-
  data Class_ a
  type Class a = ID (Class_ a)
-
+type MetaClass a = Class (Class_ a)


  unsafeGetClassObject :: String -> Class a

-
  foreign import ccall unsafe "Class.h getClassByName"
      c_getClassByName :: CString -> IO (Ptr ObjCObject)

@@ -30,6 +28,16 @@
      getClassByName name >>= importImmortal


+unsafeGetMetaclassForClass :: Class a -> MetaClass a
+
+foreign import ccall unsafe "Class.h getClassForObject"
+    c_getClassForObject :: Ptr ObjCObject -> IO (Ptr ObjCObject)
+
+getClassForObject obj = withExportedArgument obj c_getClassForObject
+
+{-# NOINLINE unsafeGetMetaclassForClass #-}
+unsafeGetMetaclassForClass obj = unsafePerformIO $
+    getClassForObject obj >>= importImmortal


  class (Object a, Object b) => ClassAndObject a b | a -> b, b -> a

Modified: branches/objc2/hoc/HOC/HOC/DeclareClass.hs
==============================================================================
--- branches/objc2/hoc/HOC/HOC/DeclareClass.hs	(original)
+++ branches/objc2/hoc/HOC/HOC/DeclareClass.hs	Wed Dec 10 07:59:54 2008
@@ -31,6 +31,12 @@
                  `appT` (conT (mkName phantomName)
                          `appT` varT (mkName "a"))),

+        -- type $(metaMetaClassName) a = $(superMetaMetaClassName)  
($(phantomName) a)
+        tySynD (mkName metaMetaClassName) [mkName "a"]
+            (conT (mkName superMetaMetaClassName)
+                `appT` (conT (mkName phantomName)
+                        `appT` varT (mkName "a"))),
+
          -- $(classObjectName) :: $(metaClassName) ()
          sigD (mkName classObjectName) (conT (mkName metaClassName)
                                              `appT` [t| () |]),
@@ -39,6 +45,11 @@
          valD (return $ VarP (mkName classObjectName))
              (normalB [| unsafeGetClassObject $(stringE name) |]) [],

+        -- $(metaClassObjectName) = unsafeGetMetaclassForClass  
$(classObjectName)
+        valD (return $ VarP (mkName metaClassObjectName))
+            (normalB [| unsafeGetMetaclassForClass $(varE (mkName  
classObjectName)) |]) [],
+
+        -- $(superName) :: String
          sigD (mkName superName) [t| String |],

          -- $(superName) = "super"
@@ -47,20 +58,35 @@
          -- instance SuperClass (name ()) (super ())
          instanceD (cxt []) (conT ''SuperClass `appT` clsType `appT`  
superType) [],

+        -- instance SuperClass (clsName ()) (superClsName ())
+        instanceD (cxt []) (conT ''SuperClass `appT` metaClsType `appT`  
superMetaType) [],
+
          -- instance ClassObject (metaClsName ())
          --  where classObject = classObject
          instanceD (cxt []) (conT ''ClassObject `appT` metaClsType)
-            [funD 'classObject [clause [] (normalB $ varE (mkName  
classObjectName)) []]]
+            [funD 'classObject [clause [] (normalB $ varE (mkName  
classObjectName)) []]],
+
+        -- instance ClassObject metaMetaCls
+        --  where classObject = unsafeGetMetaclassForClass classObject
+        --  {- metaclass object, to support super calls in class methods -}
+        instanceD (cxt []) (conT ''ClassObject `appT` metaMetaClsType)
+            [funD 'classObject [clause [] (normalB $ varE (mkName  
metaClassObjectName)) []]]
      ]
      where
          phantomName = name ++ "_"
          metaClassName = name ++ "Class"
+        metaMetaClassName = name ++ "MetaClass"
          metaPhantomName = metaClassName ++ "_"
          superMetaClassName | super == "ID" = "Class"
                             | otherwise = super ++ "Class"
+        superMetaMetaClassName | super == "ID" = "MetaClass"
+                               | otherwise = super ++ "MetaClass"
          classObjectName = "_" ++ name
+        metaClassObjectName = "_" ++ metaClassName
          superName = "super_" ++ name

+        metaMetaClsType = conT (mkName metaMetaClassName) `appT` [t| () |]
          metaClsType = conT (mkName metaClassName) `appT` [t| () |]
          clsType   = conT (mkName name)  `appT` [t| () |]
          superType = conT (mkName super) `appT` [t| () |]
+        superMetaType = conT (mkName superMetaClassName) `appT` [t| () |]

Modified: branches/objc2/hoc/Tests/TestFoundation.hs
==============================================================================
--- branches/objc2/hoc/Tests/TestFoundation.hs	(original)
+++ branches/objc2/hoc/Tests/TestFoundation.hs	Wed Dec 10 07:59:54 2008
@@ -94,16 +94,19 @@

  $(declareClass "HaskellObjectCountingInvocations" "NSObject")
  $(exportClass "HaskellObjectCountingInvocations" "hoci_1_" [
-        InstanceMethod 'countInvocationsUpto
+        InstanceMethod 'countInvocationsUpto,
+        ClassMethod 'countInvocationsUpto
      ])

  instance Has_countInvocationsUpto (HaskellObjectCountingInvocations a)
+instance Has_countInvocationsUpto (HaskellObjectCountingInvocationsClass a)

  hoci_1_countInvocationsUpto start limit self = return (start + 1)

   
$(declareClass "HaskellObjectUsingSuper" "HaskellObjectCountingInvocations")
  $(exportClass "HaskellObjectUsingSuper" "hoci_2_" [
-        InstanceMethod 'countInvocationsUpto
+        InstanceMethod 'countInvocationsUpto,
+        ClassMethod 'countInvocationsUpto
      ])

  hoci_2_countInvocationsUpto start limit self
@@ -268,7 +271,7 @@
                  str <- hobj # description
                  fromNSString str @?= "<HaskellObjectWithDescription: TEST>"
              ),
-            "chaining" ~: test [
+            "instanceChaining" ~: test [
                  "base" ~: (assertNoLeaks $ do
                      hobj <- _HaskellObjectCountingInvocations # alloc >>=  
init
                      count <- hobj # countInvocationsUpto 0 100
@@ -284,6 +287,22 @@
                      count <- hobj # countInvocationsUpto 0 100
                      count @?= 2
                  )
+
+            ],
+            "classChaining" ~: test [
+                "base" ~: (assertNoLeaks $ do
+                    count <- _HaskellObjectCountingInvocations #  
countInvocationsUpto 0 100
+                    count @?= 1
+                ),
+                "subclass" ~: (assertNoLeaks $ do
+                    count <- _HaskellObjectUsingSuper #  
countInvocationsUpto 0 100
+                    count @?= 2
+                ),
+                "subsubclass" ~: (assertNoLeaks $ do
+                    count <- _HaskellSubclassOfObjectUsingSuper #  
countInvocationsUpto 0 100
+                    count @?= 2
+                )
+
              ]
          ],
          "structs" ~: test [