X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FClass.lhs;h=abf7e4b7ad5134e311143d70c9307316ef7d2b16;hb=d5c4754dcb857be7b9f4dbf6482e6050a9cd0991;hp=016ce1bfbed54ee6096c2d588f72417780ea15ab;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git

diff --git a/compiler/types/Class.lhs b/compiler/types/Class.lhs
index 016ce1b..abf7e4b 100644
--- a/compiler/types/Class.lhs
+++ b/compiler/types/Class.lhs
@@ -5,11 +5,13 @@
 
 \begin{code}
 module Class (
-	Class, ClassOpItem, FunDep,
+	Class, ClassOpItem, 
 	DefMeth (..),
 
+	FunDep,	pprFundeps,
+
 	mkClass, classTyVars, classArity,
-	classKey, className, classSelIds, classTyCon, classMethods,
+	classKey, className, classATs, classSelIds, classTyCon, classMethods,
 	classBigSig, classExtraBigSig, classTvsFds, classSCTheta
     ) where
 
@@ -36,24 +38,27 @@ A @Class@ corresponds to a Greek kappa in the static semantics:
 \begin{code}
 data Class
   = Class {
-	classKey  :: Unique,			-- Key for fast comparison
+	classKey  :: Unique,		-- Key for fast comparison
 	className :: Name,
 	
-	classTyVars  :: [TyVar],		-- The class type variables
-	classFunDeps :: [FunDep TyVar],		-- The functional dependencies
+	classTyVars  :: [TyVar],	-- The class type variables
+	classFunDeps :: [FunDep TyVar],	-- The functional dependencies
+
+	classSCTheta :: [PredType],	-- Immediate superclasses, and the
+	classSCSels  :: [Id],		-- corresponding selector functions
+					-- to extract them from a dictionary
+					-- of this class
 
-	classSCTheta :: [PredType],		-- Immediate superclasses, and the
-	classSCSels  :: [Id],			-- corresponding selector functions to
-						-- extract them from a dictionary of this
-						-- class
+        classATs     :: [TyCon],	-- Associated type families
 
-	classOpStuff :: [ClassOpItem],		-- Ordered by tag
+	classOpStuff :: [ClassOpItem],	-- Ordered by tag
 
-	classTyCon :: TyCon		-- The data type constructor for dictionaries
-  }					-- of this class
+	classTyCon :: TyCon		-- The data type constructor for
+					-- dictionaries of this class
+     }
 
-type FunDep a	  = ([a],[a])	--  e.g. class C a b c |  a b -> c, a c -> b  where ...
-				--  Here fun-deps are [([a,b],[c]), ([a,c],[b])]
+type FunDep a = ([a],[a])  --  e.g. class C a b c | a b -> c, a c -> b where...
+			   --  Here fun-deps are [([a,b],[c]), ([a,c],[b])]
 
 type ClassOpItem = (Id, DefMeth)
 	-- Selector function; contains unfolding
@@ -71,11 +76,12 @@ The @mkClass@ function fills in the indirect superclasses.
 mkClass :: Name -> [TyVar]
 	-> [([TyVar], [TyVar])]
 	-> [PredType] -> [Id]
+	-> [TyCon]
 	-> [ClassOpItem]
 	-> TyCon
 	-> Class
 
-mkClass name tyvars fds super_classes superdict_sels
+mkClass name tyvars fds super_classes superdict_sels ats 
 	op_stuff tycon
   = Class {	classKey = getUnique name, 
 		className = name,
@@ -83,6 +89,7 @@ mkClass name tyvars fds super_classes superdict_sels
 		classFunDeps = fds,
 		classSCTheta = super_classes,
 		classSCSels = superdict_sels,
+		classATs = ats,
 		classOpStuff = op_stuff,
 		classTyCon = tycon }
 \end{code}
@@ -116,8 +123,8 @@ classBigSig (Class {classTyVars = tyvars, classSCTheta = sc_theta,
   = (tyvars, sc_theta, sc_sels, op_stuff)
 classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps,
 			 classSCTheta = sc_theta, classSCSels = sc_sels,
-			 classOpStuff = op_stuff})
-  = (tyvars, fundeps, sc_theta, sc_sels, op_stuff)
+			 classATs = ats, classOpStuff = op_stuff})
+  = (tyvars, fundeps, sc_theta, sc_sels, ats, op_stuff)
 \end{code}
 
 
@@ -159,6 +166,12 @@ instance Outputable DefMeth where
     ppr DefMeth     =  text "{- has default method -}"
     ppr GenDefMeth  =  text "{- has generic method -}"
     ppr NoDefMeth   =  empty   -- No default method
-\end{code}
 
+pprFundeps :: Outputable a => [FunDep a] -> SDoc
+pprFundeps []  = empty
+pprFundeps fds = hsep (ptext SLIT("|") : punctuate comma (map ppr_fd fds))
+	       where
+		 ppr_fd (us, vs) = hsep [interppSP us, ptext SLIT("->"), 
+					 interppSP vs]
+\end{code}