From: simonmar <unknown>
Date: Mon, 13 Nov 2000 10:34:52 +0000 (+0000)
Subject: [project @ 2000-11-13 10:34:52 by simonmar]
X-Git-Tag: Approximately_9120_patches~3374
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=12c932dc23931224b3795736ac27c1d3750df00f;p=ghc-hetmet.git

[project @ 2000-11-13 10:34:52 by simonmar]
merge rev. 1.46.2.3 from ghc-4-07-branch (fix line numbers in
defaulting warnings).
---

diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs
index d046461..7098929 100644
--- a/ghc/compiler/typecheck/TcSimplify.lhs
+++ b/ghc/compiler/typecheck/TcSimplify.lhs
@@ -1226,19 +1226,36 @@ addAmbigErr ambig_tv_fn dict
     (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
 
 warnDefault dicts default_ty
-  = doptsTc Opt_WarnTypeDefaults  `thenTc` \ warn ->
-    if warn then warnTc True msg else returnNF_Tc ()
+  = doptsTc Opt_WarnTypeDefaults  `thenTc` \ warn_flag ->
+    if warn_flag 
+	then mapNF_Tc warn groups  `thenNF_Tc_`  returnNF_Tc ()
+	else returnNF_Tc ()
 
   where
-    msg | length dicts > 1 
-	= (ptext SLIT("Defaulting the following constraint(s) to type") <+> quotes (ppr default_ty))
-	  $$ pprInstsInFull tidy_dicts
-	| otherwise
-	= ptext SLIT("Defaulting") <+> quotes (pprInst (head tidy_dicts)) <+> 
-	  ptext SLIT("to type") <+> quotes (ppr default_ty)
-
+	-- Tidy them first
     (_, tidy_dicts) = mapAccumL tidyInst emptyTidyEnv dicts
 
+	-- Group the dictionaries by source location
+    groups      = equivClasses cmp tidy_dicts
+    i1 `cmp` i2 = get_loc i1 `compare` get_loc i2
+    get_loc i   = case instLoc i of { (_,loc,_) -> loc }
+
+    warn [dict] = tcAddSrcLoc (get_loc dict) $
+		  warnTc True (ptext SLIT("Defaulting") <+> quotes (pprInst dict) <+> 
+			       ptext SLIT("to type") <+> quotes (ppr default_ty))
+
+    warn dicts  = tcAddSrcLoc (get_loc (head dicts)) $
+		  warnTc True (vcat [ptext SLIT("Defaulting the following constraint(s) to type") <+> quotes (ppr default_ty),
+				     pprInstsInFull dicts])
+
+addRuleLhsErr dict
+  = addInstErrTcM (instLoc dict)
+	(tidy_env,
+	 vcat [ptext SLIT("Could not deduce") <+> quotes (pprInst tidy_dict),
+	       nest 4 (ptext SLIT("LHS of a rule must have no overloading"))])
+  where
+    (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
+
 addTopIPErr dict
   = addInstErrTcM (instLoc dict) 
 	(tidy_env,