X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=da1ad9f13a0ddad4f5d651c857bfd69da0bcd9e0;hb=05446f0f1e826cd95c8bbcc355015a02ec8595ca;hp=5de2b808e3e7b7a516f0b450ea35c804b4c52127;hpb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index 5de2b80..da1ad9f 100644
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -5,160 +5,364 @@
 
 \begin{code}
 module TcTyClsDecls (
-	tcTyAndClassDecls1
+	tcTyAndClassDecls
     ) where
 
 #include "HsVersions.h"
 
-import HsSyn		( HsDecl(..), TyDecl(..), ClassDecl(..), 
-			  HsType(..), HsTyVar,
-			  ConDecl(..), ConDetails(..), BangType(..),
-			  Sig(..),
-			  hsDeclName
+import HsSyn		( HsDecl(..), TyClDecl(..),
+			  HsType(..), HsTyVarBndr,
+			  ConDecl(..), ConDetails(..), 
+			  Sig(..), HsPred(..), HsTupCon(..),
+			  tyClDeclName, hsTyVarNames, isClassDecl, isSynDecl, isClassOpSig, getBangType
 			)
-import RnHsSyn		( RenamedHsDecl )
-import RnEnv		( listTyCon_name, tupleTyCon_name ) -- ToDo: move these
-import BasicTypes	( RecFlag(..), Arity )
+import RnHsSyn		( RenamedHsDecl, RenamedTyClDecl, listTyCon_name )
+import BasicTypes	( RecFlag(..), NewOrData(..) )
 
 import TcMonad
-import Inst		( InstanceMapper )
+import TcEnv		( TcEnv, TyThing(..), TyThingDetails(..),
+			  tcExtendKindEnv, tcLookupGlobal, tcExtendGlobalEnv )
+import TcTyDecls	( tcTyDecl1, kcConDetails, mkNewTyConRep )
 import TcClassDcl	( tcClassDecl1 )
-import TcEnv		( TcIdOcc(..), GlobalValueEnv, tcExtendTyConEnv, tcExtendClassEnv )
-import TcType		( TcKind, newKindVar, newKindVars, kindToTcKind )
-import TcTyDecls	( tcTyDecl )
-import TcMonoType	( tcTyVarScope )
-
-import TyCon		( tyConKind, tyConArity, isSynTyCon )
-import Class		( Class, classBigSig )
-import Var		( tyVarKind )
-import Bag	
+import TcMonoType	( kcHsTyVars, kcHsType, kcHsBoxedSigType, kcHsContext, mkTyClTyVars )
+import TcType		( TcKind, newKindVar, zonkKindEnv )
+
+import TcUnify		( unifyKind )
+import TcInstDcls	( tcAddDeclCtxt )
+import Type		( Kind, mkArrowKind, boxedTypeKind, zipFunTys )
+import Variance         ( calcTyConArgVrcs )
+import Class		( Class, mkClass, classTyCon )
+import TyCon		( TyCon, tyConKind, ArgVrcs, AlgTyConFlavour(..), 
+			  mkSynTyCon, mkAlgTyConRep, mkClassTyCon )
+import DataCon		( isNullaryDataCon )
+import Var		( varName )
+import FiniteMap
 import Digraph		( stronglyConnComp, SCC(..) )
-import Name		( Name, NamedThing(..), getSrcLoc, isTvOcc, nameOccName )
+import Name		( Name, NamedThing(..), NameEnv, getSrcLoc, isTvOcc, nameOccName,
+			  mkNameEnv, lookupNameEnv_NF
+			)
 import Outputable
-import Maybes		( mapMaybe )
-import UniqSet		( UniqSet, emptyUniqSet,
-			  unitUniqSet, unionUniqSets, 
+import Maybes		( mapMaybe, catMaybes )
+import UniqSet		( emptyUniqSet, unitUniqSet, unionUniqSets, 
 			  unionManyUniqSets, uniqSetToList ) 
-import SrcLoc		( SrcLoc )
-import TyCon		( TyCon )
+import ErrUtils		( Message )
 import Unique		( Unique, Uniquable(..) )
-import Util		( panic{-, pprTrace-} )
-
+import HsDecls          ( fromClassDeclNameList )
+import Generics         ( mkTyConGenInfo )
+import CmdLineOpts	( DynFlags )
 \end{code}
 
+
+%************************************************************************
+%*									*
+\subsection{Type checking for type and class declarations}
+%*									*
+%************************************************************************
+
 The main function
 ~~~~~~~~~~~~~~~~~
 \begin{code}
-tcTyAndClassDecls1 :: GlobalValueEnv -> InstanceMapper	-- Knot tying stuff
-		   -> [RenamedHsDecl]
-		   -> TcM s (TcEnv s)
+tcTyAndClassDecls :: TcEnv		-- Knot tying stuff
+		  -> [RenamedHsDecl]
+		  -> TcM TcEnv
 
-tcTyAndClassDecls1 unf_env inst_mapper decls
+tcTyAndClassDecls unf_env decls
   = sortByDependency decls 		`thenTc` \ groups ->
-    tcGroups unf_env inst_mapper groups
+    tcGroups unf_env groups
 
-tcGroups unf_env inst_mapper []
+tcGroups unf_env []
   = tcGetEnv	`thenNF_Tc` \ env ->
     returnTc env
 
-tcGroups unf_env inst_mapper (group:groups)
-  = tcGroup unf_env inst_mapper group	`thenTc` \ (group_tycons, group_classes) ->
-
-	-- Extend the environment using the new tycons and classes
-    tcExtendTyConEnv [(getName tycon, (kindToTcKind (tyConKind tycon),
-				       if isSynTyCon tycon then Just (tyConArity tycon) else Nothing,
-				       tycon))
-		     | tycon <- group_tycons]	 $
-
-    tcExtendClassEnv [(getName clas, (classKind clas, clas))
-		     | clas <- group_classes]	 $
-
-
-	-- Do the remaining groups
-    tcGroups unf_env inst_mapper groups
-  where
-    classKind clas = map (kindToTcKind . tyVarKind) tyvars
-		   where
-		     (tyvars, _, _, _, _) = classBigSig clas
+tcGroups unf_env (group:groups)
+  = tcGroup unf_env group	`thenTc` \ env ->
+    tcSetEnv env			$
+    tcGroups unf_env groups
 \end{code}
 
 Dealing with a group
 ~~~~~~~~~~~~~~~~~~~~
+Consider a mutually-recursive group, binding 
+a type constructor T and a class C.
+
+Step 1: 	getInitialKind
+	Construct a KindEnv by binding T and C to a kind variable 
+
+Step 2: 	kcTyClDecl
+	In that environment, do a kind check
+
+Step 3: Zonk the kinds
+
+Step 4: 	buildTyConOrClass
+	Construct an environment binding T to a TyCon and C to a Class.
+	a) Their kinds comes from zonking the relevant kind variable
+	b) Their arity (for synonyms) comes direct from the decl
+	c) The funcional dependencies come from the decl
+	d) The rest comes a knot-tied binding of T and C, returned from Step 4
+	e) The variances of the tycons in the group is calculated from 
+		the knot-tied stuff
+
+Step 5: 	tcTyClDecl1
+	In this environment, walk over the decls, constructing the TyCons and Classes.
+	This uses in a strict way items (a)-(c) above, which is why they must
+	be constructed in Step 4.
+	Feed the results back to Step 4.
+	
+The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
+@TyThing@s.  @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
 
-Notice the uses of @zipLazy@, which makes sure
-that the knot-tied TyVars, TyCons and Classes aren't looked at too early.
-
-    
 \begin{code}
-tcGroup :: GlobalValueEnv -> InstanceMapper -> SCC RenamedHsDecl -> TcM s ([TyCon], [Class])
-tcGroup unf_env inst_mapper scc
-  = 	-- TIE THE KNOT
-    fixTc ( \ ~(rec_tycons, rec_classes) ->
-
-		-- EXTEND TYPE AND CLASS ENVIRONMENTS
-      let
-        mk_tycon_bind (name, arity) = newKindVar	`thenNF_Tc` \ kind ->
-				      returnNF_Tc (name, (kind, arity, find name rec_tycons))
-
-	mk_class_bind (name, arity) = newKindVars arity	 `thenNF_Tc` \ kinds ->
-				      returnNF_Tc (name, (kinds, find name rec_classes))
-
-        find name []		 = pprPanic "tcGroup" (ppr name)
-	find name (thing:things) | name == getName thing = thing
-				 | otherwise		 = find name things
-
-      in
-      mapNF_Tc mk_tycon_bind tycon_names_w_arities    `thenNF_Tc` \ tycon_binds ->
-      mapNF_Tc mk_class_bind class_names_w_arities    `thenNF_Tc` \ class_binds ->
-      tcExtendTyConEnv tycon_binds	  $
-      tcExtendClassEnv class_binds	  $
-
-		-- DEAL WITH TYPE VARIABLES
-      tcTyVarScope tyvar_names 			( \ tyvars ->
-
-		-- DEAL WITH THE DEFINITIONS THEMSELVES
-	foldlTc (tcDecl is_rec_group unf_env inst_mapper) ([], []) decls
-      )						`thenTc` \ (tycons, classes) ->
-
-      returnTc (tycons, classes)
-    )
+tcGroup :: TcEnv -> SCC RenamedTyClDecl -> TcM TcEnv
+tcGroup unf_env scc
+  = getDOptsTc							`thenTc` \ dflags ->
+	-- Step 1
+    mapNF_Tc getInitialKind decls 				`thenNF_Tc` \ initial_kinds ->
+
+	-- Step 2
+    tcExtendKindEnv initial_kinds (mapTc kcTyClDecl decls)	`thenTc_`
+
+	-- Step 3
+    zonkKindEnv initial_kinds			`thenNF_Tc` \ final_kinds ->
+
+	-- Tie the knot
+    fixTc ( \ ~(rec_details_list,  _) ->
+		-- Step 4 
+ 	let
+	    kind_env    = mkNameEnv final_kinds
+	    rec_details = mkNameEnv rec_details_list
+
+	    tyclss, all_tyclss :: [(Name, TyThing)]
+	    tyclss = map (buildTyConOrClass dflags is_rec kind_env 
+				                   rec_vrcs rec_details) decls
+
+		-- Add the tycons that come from the classes
+		-- We want them in the environment because 
+		-- they are mentioned in interface files
+	    all_tyclss  = [ (getName tycon, ATyCon tycon) | (_, AClass clas) <- tyclss,
+							    let tycon = classTyCon clas
+			  ] ++ tyclss
+
+		-- Calculate variances, and (yes!) feed back into buildTyConOrClass.
+            rec_vrcs    = calcTyConArgVrcs [tc | (_, ATyCon tc) <- all_tyclss]
+	in
+		-- Step 5
+	tcExtendGlobalEnv all_tyclss		$
+	mapTc (tcTyClDecl1 unf_env) decls	`thenTc` \ tycls_details ->
+	tcGetEnv				`thenNF_Tc` \ env -> 
+	returnTc (tycls_details, env)
+    )						`thenTc` \ (_, env) ->
+    returnTc env
   where
-    is_rec_group = case scc of
-			AcyclicSCC _ -> NonRecursive
-			CyclicSCC _  -> Recursive
+    is_rec = case scc of
+		AcyclicSCC _ -> NonRecursive
+		CyclicSCC _  -> Recursive
 
     decls = case scc of
 		AcyclicSCC decl -> [decl]
 		CyclicSCC decls -> decls
 
-    (tyvar_names, tycon_names_w_arities, class_names_w_arities) = get_binders decls
+tcTyClDecl1 unf_env decl
+  = tcAddDeclCtxt decl			$
+    if isClassDecl decl then
+	tcClassDecl1 unf_env decl
+    else
+	tcTyDecl1 decl
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{Step 1: Initial environment}
+%*									*
+%************************************************************************
+
+\begin{code}
+getInitialKind :: RenamedTyClDecl -> NF_TcM (Name, TcKind)
+getInitialKind (TySynonym name tyvars _ _)
+ = kcHsTyVars tyvars	`thenNF_Tc` \ arg_kinds ->
+   newKindVar		`thenNF_Tc` \ result_kind  ->
+   returnNF_Tc (name, mk_kind arg_kinds result_kind)
+
+getInitialKind (TyData _ _ name tyvars _ _ _ _ _ _ _)
+ = kcHsTyVars tyvars	`thenNF_Tc` \ arg_kinds ->
+   returnNF_Tc (name, mk_kind arg_kinds boxedTypeKind)
+
+getInitialKind (ClassDecl _ name tyvars _ _ _ _ _ _ )
+ = kcHsTyVars tyvars	`thenNF_Tc` \ arg_kinds ->
+   returnNF_Tc (name, mk_kind arg_kinds boxedTypeKind)
+
+mk_kind tvs_w_kinds res_kind = foldr (mkArrowKind . snd) res_kind tvs_w_kinds
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{Step 2: Kind checking}
+%*									*
+%************************************************************************
+
+We need to kind check all types in the mutually recursive group
+before we know the kind of the type variables.  For example:
+
+class C a where
+   op :: D b => a -> b -> b
+
+class D c where
+   bop :: (Monad c) => ...
+
+Here, the kind of the locally-polymorphic type variable "b"
+depends on *all the uses of class D*.  For example, the use of
+Monad c in bop's type signature means that D must have kind Type->Type.
+
+\begin{code}
+kcTyClDecl :: RenamedTyClDecl -> TcM ()
+
+kcTyClDecl decl@(TySynonym tycon_name hs_tyvars rhs loc)
+  = tcAddDeclCtxt decl			$
+    kcTyClDeclBody tycon_name hs_tyvars	$ \ result_kind ->
+    kcHsType rhs			`thenTc` \ rhs_kind ->
+    unifyKind result_kind rhs_kind
+
+kcTyClDecl decl@(TyData _ context tycon_name hs_tyvars con_decls _ _ _ loc _ _)
+  = tcAddDeclCtxt decl			$
+    kcTyClDeclBody tycon_name hs_tyvars	$ \ result_kind ->
+    kcHsContext context			`thenTc_` 
+    mapTc_ kc_con_decl con_decls
+  where
+    kc_con_decl (ConDecl _ _ ex_tvs ex_ctxt details loc)
+      = tcAddSrcLoc loc			$
+	kcHsTyVars ex_tvs		`thenNF_Tc` \ kind_env ->
+	tcExtendKindEnv kind_env	$
+	kcConDetails ex_ctxt details
+
+kcTyClDecl decl@(ClassDecl context class_name
+			   hs_tyvars fundeps class_sigs
+		      	   _ _ _ loc)
+  = tcAddDeclCtxt decl			$
+    kcTyClDeclBody class_name hs_tyvars	$ \ result_kind ->
+    kcHsContext context			`thenTc_`
+    mapTc_ kc_sig (filter isClassOpSig class_sigs)
+  where
+    kc_sig (ClassOpSig _ _ op_ty loc) = tcAddSrcLoc loc (kcHsBoxedSigType op_ty)
+
+kcTyClDeclBody :: Name -> [HsTyVarBndr Name] 	-- Kind of the tycon/cls and its tyvars
+	       -> (Kind -> TcM a)		-- Thing inside
+	       -> TcM a
+-- Extend the env with bindings for the tyvars, taken from
+-- the kind of the tycon/class.  Give it to the thing inside, and 
+-- check the result kind matches
+kcTyClDeclBody tc_name hs_tyvars thing_inside
+  = tcLookupGlobal tc_name		`thenNF_Tc` \ thing ->
+    let
+	kind = case thing of
+		  ATyCon tc -> tyConKind tc
+		  AClass cl -> tyConKind (classTyCon cl)
+		-- For some odd reason, a class doesn't include its kind
+
+	(tyvars_w_kinds, result_kind) = zipFunTys (hsTyVarNames hs_tyvars) kind
+    in
+    tcExtendKindEnv tyvars_w_kinds (thing_inside result_kind)
 \end{code}
 
-Dealing with one decl
-~~~~~~~~~~~~~~~~~~~~~
+
+%************************************************************************
+%*									*
+\subsection{Step 4: Building the tycon/class}
+%*									*
+%************************************************************************
+
 \begin{code}
-tcDecl  :: RecFlag 			-- True => recursive group
-	-> GlobalValueEnv -> InstanceMapper
-	-> ([TyCon], [Class])		-- Accumulating parameter
-	-> RenamedHsDecl
-	-> TcM s ([TyCon], [Class])
-
-tcDecl is_rec_group unf_env inst_mapper (tycons, classes) (TyD decl)
-  = tcTyDecl is_rec_group decl	`thenTc` \ tycon ->
-    returnTc (tycon:tycons, classes)
-
-tcDecl is_rec_group unf_env inst_mapper (tycons, classes) (ClD decl)
-  = tcClassDecl1 unf_env inst_mapper decl   `thenTc` \ clas ->
-    returnTc (tycons, clas:classes)
+buildTyConOrClass 
+	:: DynFlags
+	-> RecFlag -> NameEnv Kind
+	-> FiniteMap TyCon ArgVrcs -> NameEnv TyThingDetails
+	-> RenamedTyClDecl -> (Name, TyThing)
+	-- Can't fail; the only reason it's in the monad 
+	-- is so it can zonk the kinds
+
+buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
+	          (TySynonym tycon_name tyvar_names rhs src_loc)
+  = (tycon_name, ATyCon tycon)
+  where
+	tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs
+	tycon_kind	    = lookupNameEnv_NF kenv tycon_name
+	arity		    = length tyvar_names
+	tyvars		    = mkTyClTyVars tycon_kind tyvar_names
+	SynTyDetails rhs_ty = lookupNameEnv_NF rec_details tycon_name
+        argvrcs		    = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
+
+buildTyConOrClass dflags is_rec kenv rec_vrcs  rec_details
+	          (TyData data_or_new context tycon_name tyvar_names _ nconstrs _ _ src_loc name1 name2)
+  = (tycon_name, ATyCon tycon)
+  where
+	tycon = mkAlgTyConRep tycon_name tycon_kind tyvars ctxt argvrcs
+			   data_cons nconstrs
+			   derived_classes
+			   flavour is_rec gen_info
+	gen_info = mkTyConGenInfo dflags tycon name1 name2
+
+	DataTyDetails ctxt data_cons derived_classes = lookupNameEnv_NF rec_details tycon_name
+
+	tycon_kind = lookupNameEnv_NF kenv tycon_name
+	tyvars	   = mkTyClTyVars tycon_kind tyvar_names
+        argvrcs	   = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
+
+	flavour = case data_or_new of
+			NewType -> NewTyCon (mkNewTyConRep tycon)
+			DataType | all isNullaryDataCon data_cons -> EnumTyCon
+				 | otherwise			  -> DataTyCon
+
+buildTyConOrClass dflags is_rec kenv rec_vrcs  rec_details
+                  (ClassDecl context class_name
+		             tyvar_names fundeps class_sigs def_methods pragmas
+		             name_list src_loc)
+  = (class_name, AClass clas)
+  where
+        (tycon_name, _, _, _) = fromClassDeclNameList name_list
+ 	clas = mkClass class_name tyvars fds
+		       sc_theta sc_sel_ids op_items
+		       tycon
+
+	tycon = mkClassTyCon tycon_name class_kind tyvars
+                             argvrcs dict_con
+			     clas 		-- Yes!  It's a dictionary 
+			     flavour
+
+	ClassDetails sc_theta sc_sel_ids op_items dict_con = lookupNameEnv_NF rec_details class_name
+
+	class_kind = lookupNameEnv_NF kenv class_name
+	tyvars	   = mkTyClTyVars class_kind tyvar_names
+        argvrcs	   = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
+	n_fields   = length sc_sel_ids + length op_items
+
+ 	flavour | n_fields == 1 = NewTyCon (mkNewTyConRep tycon)
+		| otherwise	= DataTyCon
+
+	-- We can find the functional dependencies right away, 
+	-- and it is vital to do so. Why?  Because in the next pass
+	-- we check for ambiguity in all the type signatures, and we
+	-- need the functional dependcies to be done by then
+	fds	   = [(map lookup xs, map lookup ys) | (xs,ys) <- fundeps]
+	tyvar_env  = mkNameEnv [(varName tv, tv) | tv <- tyvars]
+	lookup     = lookupNameEnv_NF tyvar_env
+
+bogusVrcs = panic "Bogus tycon arg variances"
 \end{code}
 
+
+%************************************************************************
+%*									*
+\subsection{Dependency analysis}
+%*									*
+%************************************************************************
+
 Dependency analysis
 ~~~~~~~~~~~~~~~~~~~
 \begin{code}
-sortByDependency :: [RenamedHsDecl] -> TcM s [SCC RenamedHsDecl]
+sortByDependency :: [RenamedHsDecl] -> TcM [SCC RenamedTyClDecl]
 sortByDependency decls
   = let		-- CHECK FOR CLASS CYCLES
-	cls_sccs   = stronglyConnComp (mapMaybe mk_cls_edges decls)
+	cls_sccs   = stronglyConnComp (mapMaybe mk_cls_edges tycl_decls)
 	cls_cycles = [ decls | CyclicSCC decls <- cls_sccs]
     in
     checkTc (null cls_cycles) (classCycleErr cls_cycles)	`thenTc_`
@@ -176,156 +380,106 @@ sortByDependency decls
     in
     returnTc decl_sccs
   where
-    edges = mapMaybe mk_edges decls
+    tycl_decls = [d | TyClD d <- decls]
+    edges      = map mk_edges tycl_decls
     
-is_syn_decl (TyD (TySynonym _ _ _ _), _, _) = True
-is_syn_decl _		                    = False
-
-is_cls_decl (ClD _, _, _) = True
-is_cls_decl other         = False
+    is_syn_decl (d, _, _) = isSynDecl d
 \end{code}
 
 Edges in Type/Class decls
 ~~~~~~~~~~~~~~~~~~~~~~~~~
+
 \begin{code}
+----------------------------------------------------
 -- mk_cls_edges looks only at the context of class decls
 -- Its used when we are figuring out if there's a cycle in the
 -- superclass hierarchy
 
-mk_cls_edges :: RenamedHsDecl -> Maybe (RenamedHsDecl, Unique, [Unique])
+mk_cls_edges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Unique, [Unique])
 
-mk_cls_edges decl@(ClD (ClassDecl ctxt name _ _ _ _ _ _ _))
-  = Just (decl, getUnique name, map (getUnique . fst) ctxt)
+mk_cls_edges decl@(ClassDecl ctxt name _ _ _ _ _ _ _)
+  = Just (decl, getUnique name, map getUnique (catMaybes (map get_clas ctxt)))
 mk_cls_edges other_decl
   = Nothing
 
+----------------------------------------------------
+mk_edges :: RenamedTyClDecl -> (RenamedTyClDecl, Unique, [Unique])
 
-mk_edges :: RenamedHsDecl -> Maybe (RenamedHsDecl, Unique, [Unique])
-
-mk_edges decl@(TyD (TyData _ ctxt name _ condecls derivs _ _))
-  = Just (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets` 
-					 get_cons condecls `unionUniqSets` 
+mk_edges decl@(TyData _ ctxt name _ condecls _ derivs _ _ _ _)
+  = (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
+					 get_cons condecls `unionUniqSets`
 					 get_deriv derivs))
 
-mk_edges decl@(TyD (TySynonym name _ rhs _))
-  = Just (decl, getUnique name, uniqSetToList (get_ty rhs))
+mk_edges decl@(TySynonym name _ rhs _)
+  = (decl, getUnique name, uniqSetToList (get_ty rhs))
 
-mk_edges decl@(ClD (ClassDecl ctxt name _ sigs _ _ _ _ _))
-  = Just (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
+mk_edges decl@(ClassDecl ctxt name _ _ sigs _ _ _ _)
+  = (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
 				         get_sigs sigs))
 
-mk_edges other_decl = Nothing
 
-get_ctxt ctxt = unionManyUniqSets (map (set_name.fst) ctxt)
+----------------------------------------------------
+get_ctxt ctxt = unionManyUniqSets (map set_name (catMaybes (map get_clas ctxt)))
+get_clas (HsPClass clas _) = Just clas
+get_clas _                 = Nothing
 
+----------------------------------------------------
 get_deriv Nothing     = emptyUniqSet
 get_deriv (Just clss) = unionManyUniqSets (map set_name clss)
 
+----------------------------------------------------
 get_cons cons = unionManyUniqSets (map get_con cons)
 
-get_con (ConDecl _ _ ctxt details _) 
+----------------------------------------------------
+get_con (ConDecl _ _ _ ctxt details _) 
   = get_ctxt ctxt `unionUniqSets` get_con_details details
 
+----------------------------------------------------
 get_con_details (VanillaCon btys)    = unionManyUniqSets (map get_bty btys)
 get_con_details (InfixCon bty1 bty2) = unionUniqSets (get_bty bty1) (get_bty bty2)
-get_con_details (NewCon ty)          =  get_ty ty
 get_con_details (RecCon nbtys)       = unionManyUniqSets (map (get_bty.snd) nbtys)
 
-get_bty (Banged ty)   = get_ty ty
-get_bty (Unbanged ty) = get_ty ty
-
-get_ty (MonoTyVar name)
-  = if isTvOcc (nameOccName name) then emptyUniqSet else set_name name
-get_ty (MonoTyApp ty1 ty2)
-  = unionUniqSets (get_ty ty1) (get_ty ty2)
-get_ty (MonoFunTy ty1 ty2)	
-  = unionUniqSets (get_ty ty1) (get_ty ty2)
-get_ty (MonoListTy ty)
-  = set_name listTyCon_name `unionUniqSets` get_ty ty
-get_ty (MonoTupleTy tys boxed)
-  = set_name (tupleTyCon_name boxed (length tys)) `unionUniqSets` get_tys tys
-get_ty (HsForAllTy _ ctxt mty)
-  = get_ctxt ctxt `unionUniqSets` get_ty mty
-get_ty other = panic "TcTyClsDecls:get_ty"
-
-get_tys tys
-  = unionManyUniqSets (map get_ty tys)
-
+----------------------------------------------------
+get_bty bty = get_ty (getBangType bty)
+
+----------------------------------------------------
+get_ty (HsTyVar name) | isTvOcc (nameOccName name) = emptyUniqSet 
+		      | otherwise		   = set_name name
+get_ty (HsAppTy ty1 ty2)	      = unionUniqSets (get_ty ty1) (get_ty ty2)
+get_ty (HsFunTy ty1 ty2)	      = unionUniqSets (get_ty ty1) (get_ty ty2)
+get_ty (HsListTy ty)		      = set_name listTyCon_name `unionUniqSets` get_ty ty
+get_ty (HsTupleTy (HsTupCon n _) tys) = set_name n `unionUniqSets` get_tys tys
+get_ty (HsUsgTy _ ty) 		      = get_ty ty
+get_ty (HsUsgForAllTy _ ty) 	      = get_ty ty
+get_ty (HsForAllTy _ ctxt mty) 	      = get_ctxt ctxt `unionUniqSets` get_ty mty
+get_ty (HsPredTy (HsPClass name _))   = set_name name
+get_ty (HsPredTy (HsPIParam _ _))     = emptyUniqSet	-- I think
+
+----------------------------------------------------
+get_tys tys = unionManyUniqSets (map get_ty tys)
+
+----------------------------------------------------
 get_sigs sigs
   = unionManyUniqSets (map get_sig sigs)
   where 
     get_sig (ClassOpSig _ _ ty _) = get_ty ty
+    get_sig (FixSig _)		  = emptyUniqSet
     get_sig other = panic "TcTyClsDecls:get_sig"
 
+----------------------------------------------------
 set_name name = unitUniqSet (getUnique name)
-
-set_to_bag set = listToBag (uniqSetToList set)
 \end{code}
 
 
-get_binders
-~~~~~~~~~~~
-Extract *binding* names from type and class decls.  Type variables are
-bound in type, data, newtype and class declarations, 
-	*and* the polytypes in the class op sigs.
-	*and* the existentially quantified contexts in datacon decls
-
-Why do we need to grab all these type variables at once, including
-those locally-quantified type variables in class op signatures?
-
-	[Incidentally, this only works because the names are all unique by now.]
-
-Because we can only commit to the final kind of a type variable when
-we've completed the mutually recursive group. For example:
-
-class C a where
-   op :: D b => a -> b -> b
-
-class D c where
-   bop :: (Monad c) => ...
-
-Here, the kind of the locally-polymorphic type variable "b"
-depends on *all the uses of class D*.  For example, the use of
-Monad c in bop's type signature means that D must have kind Type->Type.
-
+%************************************************************************
+%*									*
+\subsection{Error management
+%*									*
+%************************************************************************
 
 \begin{code}
-get_binders :: [RenamedHsDecl]
-	    -> ([HsTyVar Name],		-- TyVars;  no dups
-		[(Name, Maybe Arity)],	-- Tycons;  no dups; arities for synonyms
-		[(Name, Arity)])	-- Classes; no dups; with their arities
+typeCycleErr, classCycleErr :: [[RenamedTyClDecl]] -> Message
 
-get_binders decls = (bagToList tyvars, bagToList tycons, bagToList classes)
-  where
-    (tyvars, tycons, classes) = foldr (union3 . get_binders1)
-				      (emptyBag,emptyBag,emptyBag)
-				      decls
-
-    union3 (a1,a2,a3) (b1,b2,b3)
-      = (a1 `unionBags` b1, a2 `unionBags` b2, a3 `unionBags` b3)
-
-get_binders1 (TyD (TySynonym name tyvars _ _))
- = (listToBag tyvars, unitBag (name, Just (length tyvars)), emptyBag)
-get_binders1 (TyD (TyData _ _ name tyvars condecls _ _ _))
- = (listToBag tyvars `unionBags` cons_tvs condecls,
-    unitBag (name,Nothing), emptyBag)
-get_binders1 (ClD (ClassDecl _ name tyvars sigs _ _ _ _ _))
- = (listToBag tyvars `unionBags` sigs_tvs sigs,
-    emptyBag, unitBag (name, length tyvars))
-
-cons_tvs condecls = unionManyBags (map con_tvs condecls)
-  where
-    con_tvs (ConDecl _ tvs _ _ _) = listToBag tvs
-
-sigs_tvs sigs = unionManyBags (map sig_tvs sigs)
-  where 
-    sig_tvs (ClassOpSig _ _ ty _) = pty_tvs ty
-    pty_tvs (HsForAllTy tvs _ _)  = listToBag tvs 	-- tvs doesn't include the class tyvar
-    pty_tvs other		  = emptyBag
-\end{code}
-
-
-\begin{code}
 typeCycleErr syn_cycles
   = vcat (map (pp_cycle "Cycle in type declarations:") syn_cycles)
 
@@ -339,5 +493,6 @@ pp_cycle str decls
     pp_decl decl
       = hsep [quotes (ppr name), ptext SLIT("at"), ppr (getSrcLoc name)]
      where
-        name = hsDeclName decl
+        name = tyClDeclName decl
+
 \end{code}