[project @ 2003-02-21 12:28:35 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcSimplify.lhs

diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs
index 9e1f4d7..6f8ed08 100644 (file)
--- 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 ->