X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FClass.lhs;h=adfbe516f2bb17d98ef985bf6bb5f2cc7501f984;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=73001e74884a4e884de392ad8bd94052bd1e1499;hpb=2f51f1402e6869c0f049ffbe7b019bf6ab80558f;p=ghc-hetmet.git

diff --git a/ghc/compiler/types/Class.lhs b/ghc/compiler/types/Class.lhs
index 73001e7..adfbe51 100644
--- a/ghc/compiler/types/Class.lhs
+++ b/ghc/compiler/types/Class.lhs
@@ -7,41 +7,41 @@
 #include "HsVersions.h"
 
 module Class (
-	GenClass(..), Class(..),
+	GenClass(..), SYN_IE(Class),
 
 	mkClass,
-	getClassKey, getClassOps, getClassSelIds,
-	getSuperDictSelId, getClassOpId, getDefaultMethodId,
-	getClassSig, getClassBigSig, getClassInstEnv,
+	classKey, classOps, classSelIds,
+	classSuperDictSelId, classOpId, classDefaultMethodId,
+	classSig, classBigSig, classInstEnv,
 	isSuperClassOf,
+	classOpTagByString,
 
-	derivableClassKeys, cCallishClassKeys,
+	derivableClassKeys, needsDataDeclCtxtClassKeys,
+	cCallishClassKeys, isNoDictClass,
 	isNumericClass, isStandardClass, isCcallishClass,
 
-	GenClassOp(..), ClassOp(..),
+	GenClassOp(..), SYN_IE(ClassOp),
 	mkClassOp,
-	getClassOpTag, getClassOpString,
-	getClassOpLocalType,
+	classOpTag, classOpString,
+	classOpLocalType,
 
-	ClassInstEnv(..)
-
-	-- and to make the interface self-sufficient...
+	SYN_IE(ClassInstEnv)
     ) where
 
 CHK_Ubiq() -- debugging consistency check
 
-import TyLoop
+IMPORT_DELOOPER(TyLoop)
 
 import TyCon		( TyCon )
-import TyVar		( TyVar(..), GenTyVar )
-import Usage		( GenUsage, Usage(..), UVar(..) )
+import TyVar		( SYN_IE(TyVar), GenTyVar )
+import Usage		( GenUsage, SYN_IE(Usage), SYN_IE(UVar) )
 
-import Maybes		( assocMaybe, Maybe )
---import Name		( Name )
+import MatchEnv		( MatchEnv )
+import Maybes		( assocMaybe )
+import Name		( changeUnique, Name )
 import Unique		-- Keys for built-in classes
---import Outputable	( Outputable(..), NamedThing(..), ExportFlag )
-import Pretty		( Pretty(..), PrettyRep )
-import PprStyle		( PprStyle )
+import Pretty		( SYN_IE(Pretty), ppCat, ppPStr )
+--import PprStyle		( PprStyle )
 import SrcLoc		( SrcLoc )
 import Util
 \end{code}
@@ -120,7 +120,7 @@ mkClass :: Unique -> Name -> TyVar
 
 mkClass uniq full_name tyvar super_classes superdict_sels
 	class_ops dict_sels defms class_insts
-  = Class uniq full_name tyvar
+  = Class uniq (changeUnique full_name uniq) tyvar
 		super_classes superdict_sels
 		class_ops dict_sels defms
 		class_insts
@@ -142,25 +142,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,28 +189,37 @@ 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
+isNoDictClass    (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` noDictClassKeys
 is_elem = isIn "is_X_Class"
 
 numericClassKeys
-  = [ numClassKey,
-      realClassKey,
-      integralClassKey,
-      fractionalClassKey,
-      floatingClassKey,
-      realFracClassKey,
-      realFloatClassKey ]
+  = [ numClassKey
+    , realClassKey
+    , integralClassKey
+    , fractionalClassKey
+    , floatingClassKey
+    , realFracClassKey
+    , realFloatClassKey
+    ]
 
 derivableClassKeys
-  = [ eqClassKey,
-      showClassKey,
-      ordClassKey,
-      boundedClassKey,
-      enumClassKey,
-      ixClassKey,
-      readClassKey ]
+  = [ eqClassKey
+    , ordClassKey
+    , enumClassKey
+    , evalClassKey
+    , boundedClassKey
+    , showClassKey
+    , readClassKey
+    , ixClassKey
+    ]
+
+needsDataDeclCtxtClassKeys -- see comments in TcDeriv
+  = [ readClassKey
+    ]
 
 cCallishClassKeys = [ cCallableClassKey, cReturnableClassKey ]
 
@@ -223,6 +232,16 @@ standardClassKeys
     --	    _ccall_ foo ... 93{-numeric literal-} ...
     --
     -- ... it can do The Right Thing on the 93.
+
+noDictClassKeys 	-- These classes are used only for type annotations;
+			-- they are not implemented by dictionaries, ever.
+  = cCallishClassKeys
+	-- I used to think that class Eval belonged in here, but
+	-- we really want functions with type (Eval a => ...) and that
+	-- means that we really want to pass a placeholder for an Eval
+	-- dictionary.  The unit tuple is what we'll get if we leave things
+	-- alone, and that'll do for now.  Could arrange to drop that parameter
+	-- in the end.
 \end{code}
 
 %************************************************************************
@@ -235,8 +254,7 @@ We compare @Classes@ by their keys (which include @Uniques@).
 
 \begin{code}
 instance Ord3 (GenClass tyvar uvar) where
-  cmp (Class k1 _ _ _ _ _ _ _ _ _) (Class k2 _ _ _ _ _ _ _ _ _)
-    = cmp k1 k2
+  cmp (Class k1 _ _ _ _ _ _ _ _ _) (Class k2 _ _ _ _ _ _ _ _ _)  = cmp k1 k2
 
 instance Eq (GenClass tyvar uvar) where
     (Class k1 _ _ _ _ _ _ _ _ _) == (Class k2 _ _ _ _ _ _ _ _ _) = k1 == k2
@@ -301,14 +319,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
 
-getClassOpString :: GenClassOp ty -> FAST_STRING
-getClassOpString (ClassOp str _ _) = str
+classOpString :: GenClassOp ty -> FAST_STRING
+classOpString (ClassOp str _ _) = str
+
+classOpLocalType :: GenClassOp ty -> ty {-SigmaType-}
+classOpLocalType (ClassOp _ _ ty) = ty
+\end{code}
 
-getClassOpLocalType :: GenClassOp ty -> ty {-SigmaType-}
-getClassOpLocalType (ClassOp _ _ ty) = ty
+Rather unsavoury ways of getting ClassOp tags:
+\begin{code}
+classOpTagByString :: Class -> FAST_STRING -> Int
+
+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}
 
 %************************************************************************