X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FClass.lhs;h=e5db71fc2ff82e31d727b4105804165faf7e1915;hb=a77abe6a30ea2763cfa1c0ca83cdce9b7200ced2;hp=9045886a2d409757d6426ea822aa576c815a0d02;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git

diff --git a/ghc/compiler/types/Class.lhs b/ghc/compiler/types/Class.lhs
index 9045886..e5db71f 100644
--- a/ghc/compiler/types/Class.lhs
+++ b/ghc/compiler/types/Class.lhs
@@ -10,22 +10,21 @@ module Class (
 	GenClass(..), Class(..),
 
 	mkClass,
-	getClassKey, getClassOps, getClassSelIds,
-	getSuperDictSelId, getClassOpId, getDefaultMethodId,
-	getClassSig, getClassBigSig, getClassInstEnv,
+	classKey, classOps, classSelIds,
+	classSuperDictSelId, classOpId, classDefaultMethodId,
+	classSig, classBigSig, classInstEnv,
 	isSuperClassOf,
+	classOpTagByString,
 
 	derivableClassKeys, cCallishClassKeys,
 	isNumericClass, isStandardClass, isCcallishClass,
 
 	GenClassOp(..), ClassOp(..),
 	mkClassOp,
-	getClassOpTag, getClassOpString,
-	getClassOpLocalType,
+	classOpTag, classOpString,
+	classOpLocalType,
 
 	ClassInstEnv(..)
-
-	-- and to make the interface self-sufficient...
     ) where
 
 CHK_Ubiq() -- debugging consistency check
@@ -37,10 +36,8 @@ import TyVar		( TyVar(..), GenTyVar )
 import Usage		( GenUsage, Usage(..), UVar(..) )
 
 import Maybes		( assocMaybe, Maybe )
-import NameTypes	( FullName, ShortName )
 import Unique		-- Keys for built-in classes
-import Outputable	( Outputable(..), NamedThing(..), ExportFlag )
-import Pretty		( Pretty(..), PrettyRep )
+import Pretty		( Pretty(..), ppCat{-ToDo:rm-}, ppPStr{-ditto-} )
 import PprStyle		( PprStyle )
 import SrcLoc		( SrcLoc )
 import Util
@@ -71,7 +68,7 @@ data GenClassOp ty
 data GenClass tyvar uvar
   = Class
 	Unique		-- Key for fast comparison
-	FullName
+	Name
 
 	tyvar	  	-- The class type variable
 
@@ -112,7 +109,7 @@ type ClassInstEnv = MatchEnv Type Id		-- The Ids are dfuns
 The @mkClass@ function fills in the indirect superclasses.
 
 \begin{code}
-mkClass :: Unique -> FullName -> TyVar
+mkClass :: Unique -> Name -> TyVar
 	-> [Class] -> [Id]
 	-> [ClassOp] -> [Id] -> [Id]
 	-> ClassInstEnv
@@ -142,25 +139,25 @@ mkClass uniq full_name tyvar super_classes superdict_sels
 The rest of these functions are just simple selectors.
 
 \begin{code}
-getClassKey (Class key _ _ _ _ _ _ _ _ _) = key
-getClassOps (Class _ _ _ _ _ ops _ _ _ _) = ops
-getClassSelIds (Class _ _ _ _ _ _ sels _ _ _) = sels
-
-getClassOpId (Class _ _ _ _ _ ops op_ids _ _ _) op
-  = op_ids !! (getClassOpTag op - 1)
-getDefaultMethodId (Class _ _ _ _ _ ops _ defm_ids _ _) op
-  = defm_ids !! (getClassOpTag op - 1)
-getSuperDictSelId (Class _ _ _ scs scsel_ids _ _ _ _ _) super_clas
-  = assoc "getSuperDictSelId" (scs `zip` scsel_ids) super_clas
-
-getClassSig :: GenClass t u -> (t, [GenClass t u], [GenClassOp (GenType t u)])
-getClassSig (Class _ _ tyvar super_classes _ ops _ _ _ _)
+classKey (Class key _ _ _ _ _ _ _ _ _) = key
+classOps (Class _ _ _ _ _ ops _ _ _ _) = ops
+classSelIds (Class _ _ _ _ _ _ sels _ _ _) = sels
+
+classOpId (Class _ _ _ _ _ ops op_ids _ _ _) op
+  = op_ids !! (classOpTag op - 1)
+classDefaultMethodId (Class _ _ _ _ _ ops _ defm_ids _ _) op
+  = defm_ids !! (classOpTag op - 1)
+classSuperDictSelId (Class _ _ _ scs scsel_ids _ _ _ _ _) super_clas
+  = assoc "classSuperDictSelId" (scs `zip` scsel_ids) super_clas
+
+classSig :: GenClass t u -> (t, [GenClass t u], [GenClassOp (GenType t u)])
+classSig (Class _ _ tyvar super_classes _ ops _ _ _ _)
   = (tyvar, super_classes, ops)
 
-getClassBigSig (Class _ _ tyvar super_classes sdsels ops sels defms _ _)
+classBigSig (Class _ _ tyvar super_classes sdsels ops sels defms _ _)
   = (tyvar, super_classes, sdsels, ops, sels, defms)
 
-getClassInstEnv (Class _ _ _ _ _ _ _ _ inst_env _) = inst_env
+classInstEnv (Class _ _ _ _ _ _ _ _ inst_env _) = inst_env
 \end{code}
 
 @a `isSuperClassOf` b@ returns @Nothing@ if @a@ is not a superclass of
@@ -189,7 +186,8 @@ because the list of ambiguous dictionaries hasn't been simplified.
 \begin{code}
 isNumericClass, isStandardClass :: Class -> Bool
 
-isNumericClass   (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` numericClassKeys
+isNumericClass   (Class key _ _ _ _ _ _ _ _ _) = --pprTrace "isNum:" (ppCat (map pprUnique (key : numericClassKeys ))) $
+						 key `is_elem` numericClassKeys
 isStandardClass  (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` standardClassKeys
 isCcallishClass	 (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` cCallishClassKeys
 is_elem = isIn "is_X_Class"
@@ -207,6 +205,7 @@ derivableClassKeys
   = [ eqClassKey,
       showClassKey,
       ordClassKey,
+      boundedClassKey,
       enumClassKey,
       ixClassKey,
       readClassKey ]
@@ -216,7 +215,7 @@ cCallishClassKeys = [ cCallableClassKey, cReturnableClassKey ]
 standardClassKeys
   = derivableClassKeys ++ numericClassKeys ++ cCallishClassKeys
     --
-    -- We have to have "_CCallable" and "_CReturnable" in the standard
+    -- We have to have "CCallable" and "CReturnable" in the standard
     -- classes, so that if you go...
     --
     --	    _ccall_ foo ... 93{-numeric literal-} ...
@@ -250,16 +249,11 @@ instance Ord (GenClass tyvar uvar) where
 \end{code}
 
 \begin{code}
+instance Uniquable (GenClass tyvar uvar) where
+    uniqueOf (Class u _ _ _ _ _ _ _ _ _) = u
+
 instance NamedThing (GenClass tyvar uvar) where
-    getExportFlag 	(Class _ n _ _ _ _ _ _ _ _) = getExportFlag n
-    isLocallyDefined	(Class _ n _ _ _ _ _ _ _ _) = isLocallyDefined n
-    getOrigName		(Class _ n _ _ _ _ _ _ _ _) = getOrigName n
-    getOccurrenceName	(Class _ n _ _ _ _ _ _ _ _) = getOccurrenceName n
-    getInformingModules	(Class _ n _ _ _ _ _ _ _ _) = getInformingModules n
-    getSrcLoc		(Class _ n _ _ _ _ _ _ _ _) = getSrcLoc n
-    fromPreludeCore	(Class _ n _ _ _ _ _ _ _ _) = fromPreludeCore n
-
-    getItsUnique (Class key _ _ _ _ _ _ _ _ _) = key
+    getName (Class _ n _ _ _ _ _ _ _ _) = n
 \end{code}
 
 
@@ -305,14 +299,29 @@ object).  Of course, the type of @op@ recorded in the GVE will be its
 mkClassOp :: FAST_STRING -> Int -> ty -> GenClassOp ty
 mkClassOp name tag ty = ClassOp name tag ty
 
-getClassOpTag :: GenClassOp ty -> Int
-getClassOpTag    (ClassOp _ tag _) = tag
+classOpTag :: GenClassOp ty -> Int
+classOpTag    (ClassOp _ tag _) = tag
+
+classOpString :: GenClassOp ty -> FAST_STRING
+classOpString (ClassOp str _ _) = str
+
+classOpLocalType :: GenClassOp ty -> ty {-SigmaType-}
+classOpLocalType (ClassOp _ _ ty) = ty
+\end{code}
 
-getClassOpString :: GenClassOp ty -> FAST_STRING
-getClassOpString (ClassOp str _ _) = str
+Rather unsavoury ways of getting ClassOp tags:
+\begin{code}
+classOpTagByString :: Class -> FAST_STRING -> Int
 
-getClassOpLocalType :: GenClassOp ty -> ty {-SigmaType-}
-getClassOpLocalType (ClassOp _ _ ty) = ty
+classOpTagByString clas op
+  = go (map classOpString (classOps clas)) 1
+  where
+    go (n:ns) tag = if n == op
+		    then tag
+		    else go ns (tag+1)
+#ifdef DEBUG
+    go []     tag = pprPanic "classOpTagByString:" (ppCat (ppPStr op : map (ppPStr . classOpString) (classOps clas)))
+#endif
 \end{code}
 
 %************************************************************************
@@ -335,4 +344,3 @@ instance Ord (GenClassOp ty) where
     (ClassOp _ i1 _) >  (ClassOp _ i2 _) = i1 >  i2
     -- ToDo: something for _tagCmp? (WDP 94/10)
 \end{code}
-