[project @ 2002-09-25 11:56:33 by simonpj]

Better location for type/class cycle errors

diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs
index 646205d..6c6e676 100644 (file)
--- 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 (file)
--- 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}