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

diff --git a/compiler/types/Class.lhs b/compiler/types/Class.lhs
index 016ce1b..e7bda63 100644
--- a/compiler/types/Class.lhs
+++ b/compiler/types/Class.lhs
@@ -1,28 +1,31 @@
 %
+% (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}
 module Class (
-	Class, ClassOpItem, FunDep,
+	Class, ClassOpItem, 
 	DefMeth (..),
 
+	FunDep,	pprFundeps, pprFunDep,
+
 	mkClass, classTyVars, classArity,
-	classKey, className, classSelIds, classTyCon, classMethods,
+	classKey, className, classATs, classSelIds, classTyCon, classMethods,
 	classBigSig, classExtraBigSig, classTvsFds, classSCTheta
     ) where
 
-#include "HsVersions.h"
-
 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
+import FastString
 \end{code}
 
 %************************************************************************
@@ -36,24 +39,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 +77,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 +90,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}
@@ -108,16 +116,20 @@ classMethods :: Class -> [Id]
 classMethods (Class {classOpStuff = op_stuff})
   = [op_sel | (op_sel, _) <- op_stuff]
 
+classTvsFds :: Class -> ([TyVar], [FunDep TyVar])
 classTvsFds c
   = (classTyVars c, classFunDeps c)
 
+classBigSig :: Class -> ([TyVar], [PredType], [Id], [ClassOpItem])
 classBigSig (Class {classTyVars = tyvars, classSCTheta = sc_theta, 
 	 	    classSCSels = sc_sels, classOpStuff = op_stuff})
   = (tyvars, sc_theta, sc_sels, op_stuff)
+
+classExtraBigSig :: Class -> ([TyVar], [FunDep TyVar], [PredType], [Id], [TyCon], [ClassOpItem])
 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 +171,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 pprFunDep fds))
+
+pprFunDep :: Outputable a => FunDep a -> SDoc
+pprFunDep (us, vs) = hsep [interppSP us, ptext (sLit "->"), interppSP vs]
+\end{code}