X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcSimplify.lhs;h=6f8ed08abd6b6e28aec13c06d638d20c02032f84;hb=802b299f16593e95deb6cc2bd5d457444ed92fd1;hp=9e1f4d7432b5ecbe323427661fac2327a0252f24;hpb=fcf37c94ff61dd721daed3515b492586f47af74a;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs
index 9e1f4d7..6f8ed08 100644
--- a/ghc/compiler/typecheck/TcSimplify.lhs
+++ b/ghc/compiler/typecheck/TcSimplify.lhs
@@ -35,7 +35,7 @@ import Inst		( lookupInst, LookupInstResult(..),
 			  instBindingRequired, instCanBeGeneralised,
 			  newDictsFromOld, tcInstClassOp,
 			  getDictClassTys, isTyVarDict,
-			  instLoc, pprInst, zonkInst, tidyInsts, tidyMoreInsts,
+			  instLoc, zonkInst, tidyInsts, tidyMoreInsts,
 			  Inst, pprInsts, pprInstsInFull,
 			  isIPDict, isInheritableInst
 			)
@@ -63,7 +63,7 @@ import VarEnv		( TidyEnv )
 import FiniteMap
 import Outputable
 import ListSetOps	( equivClasses )
-import Util		( zipEqual )
+import Util		( zipEqual, isSingleton )
 import List		( partition )
 import CmdLineOpts
 \end{code}
@@ -1608,6 +1608,8 @@ It's OK: the final zonking stage should zap y to (), which is fine.
 
 \begin{code}
 tcSimplifyTop :: [Inst] -> TcM TcDictBinds
+-- The TcLclEnv should be valid here, solely to improve
+-- error message generation for the monomorphism restriction
 tcSimplifyTop wanteds
   = getLclEnv							`thenM` \ lcl_env ->
     traceTc (text "tcSimplifyTop" <+> ppr (lclEnvElts lcl_env))	`thenM_`
@@ -1953,15 +1955,25 @@ addTopInstanceErrs tidy_env tidy_dicts
 		   
 
 addTopAmbigErrs (tidy_env, tidy_dicts)
-  = groupErrs report tidy_dicts
+-- Divide into groups that share a common set of ambiguous tyvars
+  = mapM report (equivClasses cmp [(d, tvs_of d) | d <- tidy_dicts])
   where
-    report dicts = mkMonomorphismMsg tidy_env dicts 	`thenM` \ (tidy_env, mono_msg) ->
-		   addErrTcM (tidy_env, mk_msg dicts $$ mono_msg)
-    mk_msg dicts = addInstLoc dicts $
-		   sep [text "Ambiguous type variable(s)" <+> pprQuotedList ambig_tvs,
-		        nest 2 (text "in the constraint" <> plural dicts <+> pprInsts dicts)]
-		where
-		   ambig_tvs = varSetElems (tyVarsOfInsts dicts)
+    tvs_of :: Inst -> [TcTyVar]
+    tvs_of d = varSetElems (tyVarsOfInst d)
+    cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2
+    
+    report :: [(Inst,[TcTyVar])] -> TcM ()
+    report pairs@((_,tvs) : _)	-- The pairs share a common set of ambiguous tyvars
+	= mkMonomorphismMsg tidy_env dicts	`thenM` \ (tidy_env, mono_msg) ->
+	  addErrTcM (tidy_env, msg $$ mono_msg)
+	where
+	  dicts = map fst pairs
+	  msg = sep [text "Ambiguous type variable" <> plural tvs <+> 
+			     pprQuotedList tvs <+> in_msg,
+		     nest 2 (pprInstsInFull dicts)]
+	  in_msg | isSingleton dicts = text "in the top-level constraint:"
+		 | otherwise         = text "in these top-level constraints:"
+
 
 mkMonomorphismMsg :: TidyEnv -> [Inst] -> TcM (TidyEnv, Message)
 -- There's an error with these Insts; if they have free type variables
@@ -1982,7 +1994,8 @@ mkMonomorphismMsg tidy_env insts
 				--	f x = show (read "foo")
 				-- whre monomorphism doesn't play any role
     mk_msg docs = vcat [ptext SLIT("Possible cause: the monomorphism restriction applied to the following:"),
-			nest 2 (vcat docs)]
+			nest 2 (vcat docs),
+			ptext SLIT("Probable fix: give these definition(s) an explicit type signature")]
     
 warnDefault dicts default_ty
   = doptM Opt_WarnTypeDefaults  `thenM` \ warn_flag ->