Menu
▾
▴
[hoc-cvs] [hoc commit] r368 - in trunk/hoc: HOC HOC/HOC Tests
|
From: <cod...@go...> - 2008-12-09 21:24:52
|
Author: jam...@us...
Date: Tue Dec 9 12:29:11 2008
New Revision: 368
Modified:
trunk/hoc/HOC/HOC.hs
trunk/hoc/HOC/HOC/Class.hs
trunk/hoc/HOC/HOC/DeclareClass.hs
trunk/hoc/HOC/HOC/NewlyAllocated.hs
trunk/hoc/HOC/HOC/Super.hs
trunk/hoc/Tests/TestFoundation.hs
Log:
Fixed super calls to chain properly (Issue 9) and added tests for the fix.
The short story:
- Added a typeclass "StaticClassAndObject" with a
method "staticClassForObject", and added an instance declaration to the
output of declareClass.
- Added a field to the SuperTarget and NewSuper constructors to carry the
targeted superclass, and changed the objc_super marshalling stuff in
Super.hs to make use of those fields.
Modified: trunk/hoc/HOC/HOC.hs
==============================================================================
--- trunk/hoc/HOC/HOC.hs (original)
+++ trunk/hoc/HOC/HOC.hs Tue Dec 9 12:29:11 2008
@@ -5,6 +5,9 @@
Object(..),
Class,
ClassAndObject,
+ StaticClassAndObject,
+ staticClassForObject,
+ staticSuperclassForObject,
( # ), ( #. ),
withExportedArray,
castObject,
@@ -36,6 +39,7 @@
SuperClass,
SuperTarget,
super,
+ castSuper,
CEnum(..),
declareCEnum,
Modified: trunk/hoc/HOC/HOC/Class.hs
==============================================================================
--- trunk/hoc/HOC/HOC/Class.hs (original)
+++ trunk/hoc/HOC/HOC/Class.hs Tue Dec 9 12:29:11 2008
@@ -35,3 +35,14 @@
class (Object a, Object b) => ClassAndObject a b | a -> b, b -> a
instance ClassAndObject (Class a) (ID a)
+
+class ClassAndObject a b => StaticClassAndObject a b
+ where
+ -- _staticClassForObject must not touch its parameter:
+ -- its value should only depend on the type of the parameter.
+ _staticClassForObject :: b -> a
+
+-- make an export-safe version; don't want people making new
+-- implementations, but they should be allowed to use the info.
+staticClassForObject :: StaticClassAndObject a b => b -> a
+staticClassForObject = _staticClassForObject
\ No newline at end of file
Modified: trunk/hoc/HOC/HOC/DeclareClass.hs
==============================================================================
--- trunk/hoc/HOC/HOC/DeclareClass.hs (original)
+++ trunk/hoc/HOC/HOC/DeclareClass.hs Tue Dec 9 12:29:11 2008
@@ -45,7 +45,12 @@
valD (return $ VarP (mkName superName)) (normalB $ stringE super)
[],
-- instance SuperClass (name ()) (super ())
- instanceD (cxt []) (conT ''SuperClass `appT` clsType `appT`
superType) []
+ instanceD (cxt []) (conT ''SuperClass `appT` clsType `appT`
superType) [],
+
+ -- instance StaticClassAndObject (name ())
+ -- where staticClassForObject _ = classObject
+ instanceD (cxt []) (conT ''StaticClassAndObject `appT` metaClsType
`appT` clsType)
+ [funD '_staticClassForObject [clause [wildP] (normalB $ varE
(mkName classObjectName)) []]]
]
where
phantomName = name ++ "_"
@@ -56,5 +61,6 @@
classObjectName = "_" ++ name
superName = "super_" ++ name
+ metaClsType = conT (mkName metaClassName) `appT` [t| () |]
clsType = conT (mkName name) `appT` [t| () |]
superType = conT (mkName super) `appT` [t| () |]
Modified: trunk/hoc/HOC/HOC/NewlyAllocated.hs
==============================================================================
--- trunk/hoc/HOC/HOC/NewlyAllocated.hs (original)
+++ trunk/hoc/HOC/HOC/NewlyAllocated.hs Tue Dec 9 12:29:11 2008
@@ -14,6 +14,8 @@
import HOC.Base ( ObjCObject )
import HOC.Arguments ( ObjCArgument(..) )
+import HOC.Class
+import HOC.ID
import HOC.MessageTarget( Object(..), MessageTarget(..) )
import HOC.MsgSend
import HOC.Super
@@ -24,15 +26,16 @@
data NewlyAllocated a
= NewlyAllocated (Ptr ObjCObject)
- | NewSuper (Ptr ObjCObject)
+ | NewSuper (Ptr ObjCObject) (Class ())
instance ObjCArgument (NewlyAllocated a) (Ptr ObjCObject) where
withExportedArgument (NewlyAllocated p) action = action p
- withExportedArgument (NewSuper p) action =
- withExportedSuper p action
+ withExportedArgument (NewSuper p cls) action =
+ withExportedArgument cls $ \cls ->
+ withExportedSuper p cls action
exportArgument (NewlyAllocated p) = return p
- exportArgument (NewSuper p) = fail "HOC.NewlyAllocated.NewSuper:
exportArgument"
+ exportArgument (NewSuper p cls) = fail "HOC.NewlyAllocated.NewSuper:
exportArgument"
importArgument p = return (NewlyAllocated p)
@@ -45,13 +48,16 @@
instance MessageTarget (NewlyAllocated a) where
isNil (NewlyAllocated p) = p == nullPtr
- isNil (NewSuper p) = p == nullPtr
+ isNil (NewSuper p cls) = (p == nullPtr) || isNil cls
sendMessageWithRetval (NewlyAllocated _) = objSendMessageWithRetval
- sendMessageWithRetval (NewSuper _) = superSendMessageWithRetval
+ sendMessageWithRetval (NewSuper _ _) = superSendMessageWithRetval
sendMessageWithoutRetval (NewlyAllocated _) =
objSendMessageWithoutRetval
- sendMessageWithoutRetval (NewSuper _) = superSendMessageWithoutRetval
+ sendMessageWithoutRetval (NewSuper _ _) = superSendMessageWithoutRetval
-instance SuperClass sub super
- => Super (NewlyAllocated sub) (NewlyAllocated super) where
- super (NewlyAllocated x) = NewSuper x
+instance (SuperClass sub (ID super), StaticClassAndObject (Class super)
(ID super))
+ => Super (NewlyAllocated sub) (NewlyAllocated (ID super)) where
+ super na@(NewlyAllocated x) = NewSuper x (castObject superClass)
+ where superClass = staticClassForObject (asSuper na)
+ asSuper :: SuperClass sub super => NewlyAllocated sub ->
super
+ asSuper _ = error "staticClassForObject must not touch its
parameter"
Modified: trunk/hoc/HOC/HOC/Super.hs
==============================================================================
--- trunk/hoc/HOC/HOC/Super.hs (original)
+++ trunk/hoc/HOC/HOC/Super.hs Tue Dec 9 12:29:11 2008
@@ -1,11 +1,14 @@
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,
- UndecidableInstances, FlexibleInstances #-}
+ UndecidableInstances, FlexibleInstances,
+ FlexibleContexts #-}
module HOC.Super(
- SuperClass, SuperTarget, Super(super), withExportedSuper
+ SuperClass, SuperTarget, Super(super), withExportedSuper,
+ staticSuperclassForObject, castSuper
) where
import HOC.Base
import HOC.Arguments
+import HOC.Class
import HOC.ID
import HOC.MsgSend
import HOC.MessageTarget
@@ -23,7 +26,7 @@
-- super, which is sufficient to define a class hierarchy.
class SuperClass sub super | sub -> super
-data SuperTarget a = SuperTarget a
+data SuperTarget a = SuperTarget a (Class ())
class Super sub super | sub -> super where
super :: sub -> super
@@ -33,32 +36,39 @@
pokeSuper objcSuper obj cls
= pokeByteOff objcSuper 0 obj >> pokeByteOff objcSuper (sizeOf obj) cls
-withExportedSuper p action =
- getSuperClassForObject p >>= \cls ->
+withExportedSuper p cls action =
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 (SuperTarget obj cls) action =
+ withExportedArgument cls $ \cls ->
withExportedArgument obj $ \p ->
- withExportedSuper p action
+ withExportedSuper p cls action
exportArgument _ = fail "HOC.Super: exportArgument"
importArgument _ = fail "HOC.Super: importArgument"
objCTypeString _ = "@" -- well, close enough.
-instance (Object (ID sub), Object super, SuperClass (ID sub) super)
- => Super (ID sub) (SuperTarget super) where
- super obj = SuperTarget (fromID $ toID obj)
+castSuper :: SuperClass (ID sub) (ID super) => ID sub -> ID super
+castSuper = castObject
-getSuperClassForObject obj = do cls <- peekByteOff obj 0 :: IO (Ptr (Ptr
()))
- peekElemOff cls 1
+staticSuperclassForObject ::
+ ( SuperClass (ID sub) (ID super)
+ , StaticClassAndObject (Class super) (ID super)
+ ) => ID sub -> Class super
+staticSuperclassForObject = staticClassForObject . castSuper
+
+instance (Object (ID sub), Object (ID super), SuperClass (ID sub) (ID
super),
+ StaticClassAndObject (Class super) (ID super))
+ => Super (ID sub) (SuperTarget (ID super)) where
+ super obj = SuperTarget (fromID $ toID obj) (castObject
(staticSuperclassForObject obj))
instance MessageTarget a => MessageTarget (SuperTarget a) where
- isNil (SuperTarget x) = isNil x
+ isNil (SuperTarget x cls) = isNil x || isNil cls
sendMessageWithRetval _ = superSendMessageWithRetval
sendMessageWithoutRetval _ = superSendMessageWithoutRetval
Modified: trunk/hoc/Tests/TestFoundation.hs
==============================================================================
--- trunk/hoc/Tests/TestFoundation.hs (original)
+++ trunk/hoc/Tests/TestFoundation.hs Tue Dec 9 12:29:11 2008
@@ -90,6 +90,30 @@
nil
>>= raise
+$(declareSelector "countInvocations:upto:" [t| Int -> Int -> IO Int |])
+
+$(declareClass "HaskellObjectCountingInvocations" "NSObject")
+$(exportClass "HaskellObjectCountingInvocations" "hoci_1_" [
+ InstanceMethod 'countInvocationsUpto
+ ])
+
+instance Has_countInvocationsUpto (HaskellObjectCountingInvocations a)
+
+hoci_1_countInvocationsUpto start limit self = return (start + 1)
+
+$(declareClass "HaskellObjectUsingSuper" "HaskellObjectCountingInvocations")
+$(exportClass "HaskellObjectUsingSuper" "hoci_2_" [
+ InstanceMethod 'countInvocationsUpto
+ ])
+
+hoci_2_countInvocationsUpto start limit self
+ | start >= limit = return start
+ | otherwise = super self # countInvocationsUpto (start + 1)
limit
+
+$(declareClass "HaskellSubclassOfObjectUsingSuper" "HaskellObjectUsingSuper")
+
+$(exportClass "HaskellSubclassOfObjectUsingSuper" "noMembers_" [])
+
tests = test [
"NSNumber" ~: test [
"alloc-initWithInt-intValue" ~: (assertNoLeaks $ do
@@ -172,7 +196,10 @@
initializeClass_HaskellObjectWithOutlet
initializeClass_HaskellObjectWithDescription
initializeClass_HaskellObjectWithIVar
- initializeClass_ExceptionThrower,
+ initializeClass_ExceptionThrower
+ initializeClass_HaskellObjectCountingInvocations
+ initializeClass_HaskellObjectUsingSuper
+ initializeClass_HaskellSubclassOfObjectUsingSuper,
"HaskellObjectWithOutlet" ~: test [
"alloc-init" ~: (assertNoLeaks $ do
@@ -235,11 +262,30 @@
result @?= expected
)
],
- "Super" ~: (assertNoLeaks $ do
- hobj <- _HaskellObjectWithDescription # alloc >>= init
- str <- hobj # description
- fromNSString str @?= "<HaskellObjectWithDescription: TEST>"
- ),
+ "Super" ~: test [
+ "description" ~: (assertNoLeaks $ do
+ hobj <- _HaskellObjectWithDescription # alloc >>= init
+ str <- hobj # description
+ fromNSString str @?= "<HaskellObjectWithDescription: TEST>"
+ ),
+ "chaining" ~: test [
+ "base" ~: (assertNoLeaks $ do
+ hobj <- _HaskellObjectCountingInvocations # alloc >>=
init
+ count <- hobj # countInvocationsUpto 0 100
+ count @?= 1
+ ),
+ "subclass" ~: (assertNoLeaks $ do
+ hobj <- _HaskellObjectUsingSuper # alloc >>= init
+ count <- hobj # countInvocationsUpto 0 100
+ count @?= 2
+ ),
+ "subsubclass" ~: (assertNoLeaks $ do
+ hobj <- _HaskellSubclassOfObjectUsingSuper # alloc >>=
init
+ count <- hobj # countInvocationsUpto 0 100
+ count @?= 2
+ )
+ ]
+ ],
"structs" ~: test [
"pointArg" ~: (do
let point = NSPoint 6.42 7.42
|
