[hoc-cvs] [hoc commit] r372 - in trunk/hoc/HOC: . HOC

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

Author: jam...@us...
Date: Wed Dec 10 06:52:25 2008
New Revision: 372

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

Log:
Simplified previous patch for Issue 9 by replacing  
newly-introduced "StaticClassAndObject" typeclass with a  
simpler "ClassObject" typeclass.

This patch touches the template-haskell code, so bindings will have to be  
rebuilt.  Sorry for any inconvenience this may cause.


Modified: trunk/hoc/HOC/HOC.hs
==============================================================================
--- trunk/hoc/HOC/HOC.hs	(original)
+++ trunk/hoc/HOC/HOC.hs	Wed Dec 10 06:52:25 2008
@@ -5,9 +5,8 @@
          Object(..),
          Class,
          ClassAndObject,
-        StaticClassAndObject,
-        staticClassForObject,
-        staticSuperclassForObject,
+        ClassObject,
+        classObject,
          ( # ), ( #. ),
          withExportedArray,
          castObject,

Modified: trunk/hoc/HOC/HOC/Class.hs
==============================================================================
--- trunk/hoc/HOC/HOC/Class.hs	(original)
+++ trunk/hoc/HOC/HOC/Class.hs	Wed Dec 10 06:52:25 2008
@@ -36,13 +36,6 @@

  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
+class Object cls => ClassObject cls
+    where
+        classObject :: cls

Modified: trunk/hoc/HOC/HOC/DeclareClass.hs
==============================================================================
--- trunk/hoc/HOC/HOC/DeclareClass.hs	(original)
+++ trunk/hoc/HOC/HOC/DeclareClass.hs	Wed Dec 10 06:52:25 2008
@@ -47,10 +47,10 @@
          -- instance SuperClass (name ()) (super ())
          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)) []]]
+        -- instance ClassObject (metaClsName ())
+        --  where classObject = classObject
+        instanceD (cxt []) (conT ''ClassObject `appT` metaClsType)
+            [funD 'classObject [clause [] (normalB $ varE (mkName  
classObjectName)) []]]
      ]
      where
          phantomName = name ++ "_"

Modified: trunk/hoc/HOC/HOC/NewlyAllocated.hs
==============================================================================
--- trunk/hoc/HOC/HOC/NewlyAllocated.hs	(original)
+++ trunk/hoc/HOC/HOC/NewlyAllocated.hs	Wed Dec 10 06:52:25 2008
@@ -1,4 +1,5 @@
-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances,  
UndecidableInstances #-}
+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances,  
UndecidableInstances,
+    ScopedTypeVariables #-}
  module HOC.NewlyAllocated where

  {-
@@ -55,9 +56,6 @@
      sendMessageWithoutRetval (NewlyAllocated _) =  
objSendMessageWithoutRetval
      sendMessageWithoutRetval (NewSuper _ _) = superSendMessageWithoutRetval

-instance (SuperClass sub (ID super), StaticClassAndObject (Class super)  
(ID super))
+instance (SuperClass sub (ID super), ClassObject (Class 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"
+    super (NewlyAllocated x) = NewSuper x (castObject (classObject ::  
Class super))

Modified: trunk/hoc/HOC/HOC/Super.hs
==============================================================================
--- trunk/hoc/HOC/HOC/Super.hs	(original)
+++ trunk/hoc/HOC/HOC/Super.hs	Wed Dec 10 06:52:25 2008
@@ -2,8 +2,7 @@
               UndecidableInstances, FlexibleInstances,
               FlexibleContexts #-}
  module HOC.Super(
-        SuperClass, SuperTarget, Super(super), withExportedSuper,
-        staticSuperclassForObject, castSuper
+        SuperClass, SuperTarget, Super(super), withExportedSuper, castSuper
      ) where

  import HOC.Base
@@ -58,14 +57,14 @@

  staticSuperclassForObject ::
      ( SuperClass (ID sub) (ID super)
-    , StaticClassAndObject (Class super) (ID super)
+    , ClassObject (Class super)
      ) => ID sub -> Class super
-staticSuperclassForObject = staticClassForObject . castSuper
+staticSuperclassForObject obj = classObject

  instance (Object (ID sub), Object (ID super), SuperClass (ID sub) (ID  
super),
-          StaticClassAndObject (Class super) (ID super))
+          ClassObject (Class super))
      => Super (ID sub) (SuperTarget (ID super)) where
-    super obj = SuperTarget (fromID $ toID obj) (castObject  
(staticSuperclassForObject obj))
+    super obj = SuperTarget (castSuper obj) (castObject  
(staticSuperclassForObject obj))

  instance MessageTarget a => MessageTarget (SuperTarget a) where
      isNil (SuperTarget x cls) = isNil x || isNil cls