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

diff --git a/compiler/types/Class.lhs b/compiler/types/Class.lhs
index 016ce1b..29ce00c 100644
--- a/compiler/types/Class.lhs
+++ b/compiler/types/Class.lhs
@@ -1,15 +1,26 @@
 %
+% (c) The University of Glasgow 2006
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-\section[Class]{The @Class@ datatype}
+
+The @Class@ datatype
 
 \begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
 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
 
@@ -18,10 +29,10 @@ module Class (
 import {-# SOURCE #-} TyCon	( TyCon )
 import {-# SOURCE #-} TypeRep	( PredType )
 
-import Var		( Id, TyVar )
-import Name		( NamedThing(..), Name )
-import BasicTypes	( Arity )
-import Unique		( Unique, Uniquable(..) )
+import Var
+import Name
+import BasicTypes
+import Unique
 import Outputable
 \end{code}
 
@@ -36,24 +47,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
 
-	classOpStuff :: [ClassOpItem],		-- Ordered by tag
+        classATs     :: [TyCon],	-- Associated type families
 
-	classTyCon :: TyCon		-- The data type constructor for dictionaries
-  }					-- of this class
+	classOpStuff :: [ClassOpItem],	-- Ordered by tag
 
-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])]
+	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 ClassOpItem = (Id, DefMeth)
 	-- Selector function; contains unfolding
@@ -71,11 +85,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 +98,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 +132,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 +175,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}