X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcTyDecls.lhs;h=1501d56f7e38ff87b446d7eaae8f03356ffccb42;hb=86b3c9519a4027be3d19a46397f0c2a1797c4606;hp=824e95c54f8c7be708917e5e776d23aea108d6de;hpb=550421384b8364cdaf3135f7859c9f7d7ee1fff1;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs
index 824e95c..1501d56 100644
--- a/ghc/compiler/typecheck/TcTyDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyDecls.lhs
@@ -13,21 +13,20 @@ files for imported data types.
 \begin{code}
 module TcTyDecls(
         calcTyConArgVrcs,
-	calcRecFlags, calcCycleErrs,
-	newTyConRhs
+	calcRecFlags, 
+	calcClassCycles, calcSynCycles
     ) where
 
 #include "HsVersions.h"
 
 import TypeRep          ( Type(..), TyNote(..), PredType(..) )  -- friend
-import HsSyn		( TyClDecl(..), HsPred(..), LTyClDecl )
+import HsSyn		( TyClDecl(..), HsPred(..), LTyClDecl, isClassDecl )
 import RnHsSyn		( extractHsTyNames )
 import Type		( predTypeRep )
-import BuildTyCl	( newTyConRhs )
 import HscTypes		( TyThing(..) )
 import TyCon            ( TyCon, ArgVrcs, tyConArity, tyConDataCons, tyConTyVars,
                           getSynTyConDefn, isSynTyCon, isAlgTyCon, isHiBootTyCon,
-			  tyConName, isNewTyCon, isProductTyCon, tyConArgVrcs )
+			  tyConName, isNewTyCon, isProductTyCon, tyConArgVrcs, newTyConRhs )
 import Class		( classTyCon )
 import DataCon          ( dataConRepArgTys, dataConOrigArgTys )
 import Var              ( TyVar )
@@ -37,7 +36,7 @@ import NameEnv
 import NameSet
 import Digraph 		( SCC(..), stronglyConnComp, stronglyConnCompR )
 import BasicTypes	( RecFlag(..) )
-import SrcLoc		( Located(..) )
+import SrcLoc		( Located(..), unLoc )
 import Outputable
 \end{code}
 
@@ -107,23 +106,25 @@ synTyConsOfType ty
 ---------------------------------------- END NOTE ]
 
 \begin{code}
-calcCycleErrs :: [LTyClDecl Name] -> ([[Name]],	-- Recursive type synonym groups
-			             [[Name]])	-- Ditto classes
-calcCycleErrs decls
-  = (findCyclics syn_edges, findCyclics cls_edges)
+calcSynCycles :: [LTyClDecl Name] -> [SCC (LTyClDecl Name)]
+calcSynCycles decls
+  = stronglyConnComp syn_edges
   where
-	--------------- Type synonyms ----------------------
-    syn_edges 	     = [ (name, mk_syn_edges rhs) | 
-			  L _ (TySynonym { tcdLName  = L _ name, 
-					   tcdSynRhs = rhs }) <- decls ]
+    syn_edges = [ (ldecl, unLoc (tcdLName decl), 
+			  mk_syn_edges (tcdSynRhs decl))
+		| ldecl@(L _ decl) <- decls ]
 
     mk_syn_edges rhs = [ tc | tc <- nameSetToList (extractHsTyNames rhs), 
 			      not (isTyVarName tc) ]
 
-	--------------- Classes ----------------------
-    cls_edges = [ (name, mk_cls_edges ctxt) | 
-		  L _ (ClassDecl { tcdLName = L _ name, 
-			           tcdCtxt  = L _ ctxt }) <- decls ]
+
+calcClassCycles :: [LTyClDecl Name] -> [[LTyClDecl Name]]
+calcClassCycles decls
+  = [decls | CyclicSCC decls <- stronglyConnComp cls_edges]
+  where
+    cls_edges = [ (ldecl, unLoc (tcdLName decl), 	
+			  mk_cls_edges (unLoc (tcdCtxt decl)))
+		| ldecl@(L _ decl) <- decls, isClassDecl decl ]
 
     mk_cls_edges ctxt = [ cls | L _ (HsClassP cls _) <- ctxt ]
 \end{code}
@@ -216,7 +217,7 @@ calcRecFlags tyclss
     nt_edges = [(t, mk_nt_edges t) | t <- new_tycons]
 
     mk_nt_edges nt 	-- Invariant: nt is a newtype
-	= concatMap (mk_nt_edges1 nt) (tcTyConsOfType (newTyConRhs nt))
+	= concatMap (mk_nt_edges1 nt) (tcTyConsOfType (new_tc_rhs nt))
 			-- tyConsOfType looks through synonyms
 
     mk_nt_edges1 nt tc 
@@ -244,13 +245,15 @@ calcRecFlags tyclss
  	| tc `elem` prod_tycons   = [tc]		-- Local product
  	| tc `elem` new_tycons    = if is_rec_nt tc 	-- Local newtype
 				    then []
-				    else mk_prod_edges1 ptc (newTyConRhs tc)
+				    else mk_prod_edges1 ptc (new_tc_rhs tc)
 	| isHiBootTyCon tc	  = [ptc]	-- Make it self-recursive if 
 						-- it mentions an hi-boot TyCon
 		-- At this point we know that either it's a local non-product data type,
 		-- or it's imported.  Either way, it can't form part of a cycle
 	| otherwise = []
 			
+new_tc_rhs tc = snd (newTyConRhs tc)	-- Ignore the type variables
+
 getTyCon (ATyCon tc) = tc
 getTyCon (AClass cl) = classTyCon cl
 
@@ -262,12 +265,6 @@ findLoopBreakers deps
     go edges = [ name
 	       | CyclicSCC ((tc,_,_) : edges') <- stronglyConnCompR edges,
 		 name <- tyConName tc : go edges']
-
-findCyclics :: [(Name,[Name])] -> [[Name]]
-findCyclics deps
-  = [names | CyclicSCC names <- stronglyConnComp edges]
-  where
-    edges = [(name,name,ds) | (name,ds) <- deps]
 \end{code}
 
 These two functions know about type representations, so they could be