From d76011037e023f66c89297a9ab130c476b9c124c Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Wed, 25 Sep 2002 11:56:34 +0000
Subject: [PATCH] [project @ 2002-09-25 11:56:33 by simonpj] Better location
 for type/class cycle errors

---
 ghc/compiler/typecheck/TcRnMonad.lhs    |   10 +++++-----
 ghc/compiler/typecheck/TcTyClsDecls.lhs |   26 +++++++++++---------------
 2 files changed, 16 insertions(+), 20 deletions(-)

diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs
index 646205d..6c6e676 100644
--- a/ghc/compiler/typecheck/TcRnMonad.lhs
+++ b/ghc/compiler/typecheck/TcRnMonad.lhs
@@ -317,10 +317,10 @@ setErrsVar v = updEnv (\ env@(Env { env_top = top_env }) ->
 			 env { env_top = top_env { top_errs = v }})
 
 addErr :: Message -> TcRn m ()
-addErr msg = do { loc <- getSrcLocM ; add_err loc msg }
+addErr msg = do { loc <- getSrcLocM ; addErrAt loc msg }
 
-add_err :: SrcLoc -> Message -> TcRn m ()
-add_err loc msg
+addErrAt :: SrcLoc -> Message -> TcRn m ()
+addErrAt loc msg
  = do {  errs_var <- getErrsVar ;
 	 rdr_env <- getGlobalRdrEnv ;
 	 let { err = addShortErrLocLine loc (unQualInScope rdr_env) msg } ;
@@ -330,7 +330,7 @@ add_err loc msg
 addErrs :: [(SrcLoc,Message)] -> TcRn m ()
 addErrs msgs = mappM_ add msgs
 	     where
-	       add (loc,msg) = add_err loc msg
+	       add (loc,msg) = addErrAt loc msg
 
 addWarn :: Message -> TcRn m ()
 addWarn msg
@@ -625,7 +625,7 @@ warnTc warn_if_true warn_msg
 \begin{code}
 add_err_tcm tidy_env err_msg loc ctxt
  = do { ctxt_msgs <- do_ctxt tidy_env ctxt ;
-	add_err loc (vcat (err_msg : ctxt_to_use ctxt_msgs)) }
+	addErrAt loc (vcat (err_msg : ctxt_to_use ctxt_msgs)) }
 
 do_ctxt tidy_env []
  = return []
diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index 875b9ce..948eca5 100644
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -463,13 +463,13 @@ checkLoops is_rec decls
 	cls_edges  = mapMaybe mkClassEdges decls
 	cls_cycles = findCycles cls_edges
     in
-    checkTc (null cls_cycles) (classCycleErr cls_cycles)	`thenM_`
+    mapM_ (cycleErr "class") cls_cycles		`thenM_`
 
     let		-- CHECK FOR SYNONYM CYCLES
 	syn_edges  = map mkEdges (filter isSynDecl decls)
 	syn_cycles = findCycles syn_edges
     in
-    checkTc (null syn_cycles) (typeCycleErr syn_cycles)		`thenM_`
+    mapM_ (cycleErr "type synonym") syn_cycles	`thenM_`
 
     let 	-- CHECK FOR NEWTYPE CYCLES
 	newtype_edges  = map mkEdges (filter is_nt_cycle_decl decls)
@@ -517,21 +517,17 @@ mkClassEdges other_decl				   	       = Nothing
 %************************************************************************
 
 \begin{code}
-typeCycleErr, classCycleErr :: [[RenamedTyClDecl]] -> Message
+cycleErr :: String -> [RenamedTyClDecl] -> TcM ()
 
-typeCycleErr syn_cycles
-  = vcat (map (pp_cycle "Cycle in type declarations:") syn_cycles)
-
-classCycleErr cls_cycles
-  = vcat (map (pp_cycle "Cycle in class declarations:") cls_cycles)
+cycleErr kind_of_decl decls
+  = addErrAt loc (ppr_cycle kind_of_decl decls)
+  where
+    loc = tcdLoc (head decls)
 
-pp_cycle str decls
-  = hang (text str)
+ppr_cycle kind_of_decl decls
+  = hang (ptext SLIT("Cycle in") <+> text kind_of_decl <+> ptext SLIT("declarations:"))
 	 4 (vcat (map pp_decl decls))
   where
-    pp_decl decl
-      = hsep [quotes (ppr name), ptext SLIT("at"), ppr (getSrcLoc name)]
-     where
-        name = tyClDeclName decl
-
+    pp_decl decl = hsep [quotes (ppr (tcdName decl)), 
+			 ptext SLIT("at"), ppr (tcdLoc decl)]
 \end{code}
-- 
1.7.10.4