From cf12ba4fd5b6b272d0a0a32372e2fb6fd42f1f71 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Wed, 25 Sep 2002 10:53:46 +0000
Subject: [PATCH] [project @ 2002-09-25 10:53:34 by simonpj] Better error
 locations for instance errors

---
 ghc/compiler/typecheck/TcRnMonad.lhs |   10 ++++++----
 ghc/compiler/types/InstEnv.lhs       |   12 +++++++-----
 2 files changed, 13 insertions(+), 9 deletions(-)

diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs
index c138fc6..646205d 100644
--- a/ghc/compiler/typecheck/TcRnMonad.lhs
+++ b/ghc/compiler/typecheck/TcRnMonad.lhs
@@ -188,7 +188,7 @@ mkImpInstEnv dflags eps hpt
   where
 	  -- We shouldn't get instance conflict errors from
 	  -- the package and home type envs
-    add dfuns inst_env = WARN( not (null errs), vcat errs ) inst_env'
+    add dfuns inst_env = WARN( not (null errs), vcat (map snd errs) ) inst_env'
 		       where
 			 (inst_env', errs) = extendInstEnv dflags inst_env dfuns
 
@@ -327,8 +327,10 @@ add_err loc msg
 	 (warns, errs) <- readMutVar errs_var ;
   	 writeMutVar errs_var (warns, errs `snocBag` err) }
 
-addErrs :: [Message] -> TcRn m ()
-addErrs msgs = mappM_ addErr msgs
+addErrs :: [(SrcLoc,Message)] -> TcRn m ()
+addErrs msgs = mappM_ add msgs
+	     where
+	       add (loc,msg) = add_err loc msg
 
 addWarn :: Message -> TcRn m ()
 addWarn msg
@@ -563,7 +565,7 @@ getInstLoc origin
 	 return (origin, loc, (tcl_ctxt env)) }
 \end{code}
 
-    The addErr functions add an error message, but do not cause failure.
+    The addErrTc functions add an error message, but do not cause failure.
     The 'M' variants pass a TidyEnv that has already been used to
     tidy up the message; we then use it to tidy the context messages
 
diff --git a/ghc/compiler/types/InstEnv.lhs b/ghc/compiler/types/InstEnv.lhs
index 50b9ec1..73a6ce9 100644
--- a/ghc/compiler/types/InstEnv.lhs
+++ b/ghc/compiler/types/InstEnv.lhs
@@ -22,7 +22,7 @@ import VarSet
 import VarEnv
 import Maybes		( MaybeErr(..), returnMaB, failMaB, thenMaB, maybeToBool )
 import Name		( getSrcLoc, nameModule )
-import SrcLoc		( isGoodSrcLoc )
+import SrcLoc		( SrcLoc, isGoodSrcLoc )
 import TcType		( Type, tcTyConAppTyCon, mkTyVarTy,
 			  tcSplitDFunTy, tyVarsOfTypes,
 			  matchTys, unifyTyListsX, allDistinctTyVars
@@ -315,15 +315,15 @@ True => overlap is permitted, but only if one template matches the other;
         not if they unify but neither is 
 
 \begin{code}
-extendInstEnv :: DynFlags -> InstEnv -> [DFunId] -> (InstEnv, [Message])
+extendInstEnv :: DynFlags -> InstEnv -> [DFunId] -> (InstEnv, [(SrcLoc,Message)])
   -- Similar, but all we have is the DFuns
 extendInstEnv dflags env dfun_ids = foldl (addToInstEnv dflags) (env, []) dfun_ids
 
 
 addToInstEnv :: DynFlags
-             -> (InstEnv, [Message])
+             -> (InstEnv, [(SrcLoc,Message)])
 	     -> DFunId
-	     -> (InstEnv, [Message])	-- Resulting InstEnv and augmented error messages
+	     -> (InstEnv, [(SrcLoc,Message)])	-- Resulting InstEnv and augmented error messages
 
 addToInstEnv dflags (inst_env, errs) dfun_id
 	-- Check first that the new instance doesn't 
@@ -441,9 +441,11 @@ overlapErr dfun1 dfun2 = addInstErr (ptext SLIT("Overlapping instance declaratio
 fundepErr  dfun1 dfun2 = addInstErr (ptext SLIT("Functional dependencies conflict between instance declarations:")) 
 				    dfun1 dfun2
 
+addInstErr :: SDoc -> DFunId -> DFunId -> (SrcLoc, Message)
 addInstErr what dfun1 dfun2 
- = hang what 2 (ppr_dfun dfun1 $$ ppr_dfun dfun2)
+ = (getSrcLoc dfun1, hang what 2 (ppr_dfun dfun1 $$ ppr_dfun dfun2))
   where
+   
     ppr_dfun dfun = pp_loc <> colon <+> pprClassPred clas tys
       where
 	(_,_,clas,tys) = tcSplitDFunTy (idType dfun)
-- 
1.7.10.4