Improve error reporting for type-improvement errors

diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs
index 241b2e2..7656198 100644 (file)
--- a/ghc/compiler/typecheck/TcSimplify.lhs
+++ b/ghc/compiler/typecheck/TcSimplify.lhs
@@ -42,9 +42,9 @@ import Inst           ( lookupInst, LookupInstResult(..),
 import TcEnv           ( tcGetGlobalTyVars, tcLookupId, findGlobals, pprBinders,
                          lclEnvElts, tcMetaTy )
 import InstEnv         ( lookupInstEnv, classInstances, pprInstances )
-import TcMType         ( zonkTcTyVarsAndFV, tcInstTyVars,
+import TcMType         ( zonkTcTyVarsAndFV, tcInstTyVars, zonkTcPredType,
                          checkAmbiguity, checkInstTermination )
-import TcType          ( TcTyVar, TcTyVarSet, ThetaType, TcPredType, 
+import TcType          ( TcTyVar, TcTyVarSet, ThetaType, TcPredType, tidyPred,
                           mkClassPred, isOverloadedTy, mkTyConApp, isSkolemTyVar,
                          mkTyVarTy, tcGetTyVar, isTyVarClassPred, mkTyVarTys,
                          tyVarsOfPred, tcEqType, pprPred, mkPredTy, tcIsTyVarTy )
@@ -55,7 +55,7 @@ import TyCon          ( TyCon )
 import Name            ( Name, getOccName, getSrcLoc )
 import NameSet         ( NameSet, mkNameSet, elemNameSet )
 import Class           ( classBigSig, classKey )
-import FunDeps         ( oclose, grow, improve, pprEquationDoc )
+import FunDeps         ( oclose, grow, improve, pprEquation )
 import PrelInfo                ( isNumericClass, isStandardClass ) 
 import PrelNames       ( splitName, fstName, sndName, integerTyConName,
                          showClassKey, eqClassKey, ordClassKey )
@@ -1660,11 +1660,21 @@ tcImprove avails
         mappM_ unify eqns      `thenM_`
        returnM False
   where
-    unify ((qtvs, pairs), doc)
-        = addErrCtxt doc                       $
+    unify ((qtvs, pairs), what1, what2)
+        = addErrCtxtM (mkEqnMsg what1 what2)   $
           tcInstTyVars (varSetElems qtvs)      `thenM` \ (_, _, tenv) ->
           mapM_ (unif_pr tenv) pairs
     unif_pr tenv (ty1,ty2) =  unifyType (substTy tenv ty1) (substTy tenv ty2)
+
+pprEquationDoc (eqn, (p1,w1), (p2,w2)) = vcat [pprEquation eqn, nest 2 (ppr p1), nest 2 (ppr p2)]
+
+mkEqnMsg (pred1,from1) (pred2,from2) tidy_env
+  = do { pred1' <- zonkTcPredType pred1; pred2' <- zonkTcPredType pred2
+       ; let { pred1'' = tidyPred tidy_env pred1'; pred2'' = tidyPred tidy_env pred2' }
+       ; let msg = vcat [ptext SLIT("When using functional dependencies to combine"),
+                         nest 2 (sep [ppr pred1'' <> comma, nest 2 from1]), 
+                         nest 2 (sep [ppr pred2'' <> comma, nest 2 from2])]
+       ; return (tidy_env, msg) }
 \end{code}
 
 The main context-reduction function is @reduce@.  Here's its game plan.

diff --git a/ghc/compiler/types/FunDeps.lhs b/ghc/compiler/types/FunDeps.lhs
index e690c22..9347f5f 100644 (file)
--- a/ghc/compiler/types/FunDeps.lhs
+++ b/ghc/compiler/types/FunDeps.lhs
@@ -7,7 +7,7 @@ It's better to read it as: "if we know these, then we're going to know these"
 
 \begin{code}
 module FunDeps (
-       Equation, pprEquation, pprEquationDoc,
+       Equation, pprEquation,
        oclose, grow, improve, 
        checkInstCoverage, checkFunDeps,
        pprFundeps
@@ -172,18 +172,19 @@ type Equation = (TyVarSet, [(Type, Type)])
 -- We usually act on an equation by instantiating the quantified type varaibles
 -- to fresh type variables, and then calling the standard unifier.
 
-pprEquationDoc (eqn, doc) = vcat [pprEquation eqn, nest 2 doc]
-
 pprEquation (qtvs, pairs) 
   = vcat [ptext SLIT("forall") <+> braces (pprWithCommas ppr (varSetElems qtvs)),
          nest 2 (vcat [ ppr t1 <+> ptext SLIT(":=:") <+> ppr t2 | (t1,t2) <- pairs])]
 
 ----------
-improve :: (Class -> [Instance])       -- Gives instances for given class
-       -> [(PredType,SDoc)]    -- Current constraints; doc says where they come from
-       -> [(Equation,SDoc)]    -- Derived equalities that must also hold
-                               -- (NB the above INVARIANT for type Equation)
-                               -- The SDoc explains why the equation holds (for error messages)
+type Pred_Loc = (PredType, SDoc)       -- SDoc says where the Pred comes from
+
+improve :: (Class -> [Instance])               -- Gives instances for given class
+       -> [Pred_Loc]                           -- Current constraints; 
+       -> [(Equation,Pred_Loc,Pred_Loc)]       -- Derived equalities that must also hold
+                                               -- (NB the above INVARIANT for type Equation)
+                                               -- The Pred_Locs explain which two predicates were
+                                               -- combined (for error messages)
 \end{code}
 
 Given a bunch of predicates that must hold, such as
@@ -222,13 +223,13 @@ improve inst_env preds
 
 ----------
 checkGroup :: (Class -> [Instance])
-          -> [(PredType,SDoc)]
-          -> [(Equation, SDoc)]
+          -> [Pred_Loc]
+          -> [(Equation, Pred_Loc, Pred_Loc)]
   -- The preds are all for the same class or implicit param
 
 checkGroup inst_env (p1@(IParam _ ty, _) : ips)
   =    -- For implicit parameters, all the types must match
-    [ ((emptyVarSet, [(ty,ty')]), mkEqnMsg p1 p2) 
+    [ ((emptyVarSet, [(ty,ty')]), p1, p2) 
     | p2@(IParam _ ty', _) <- ips, not (ty `tcEqType` ty')]
 
 checkGroup inst_env clss@((ClassP cls _, _) : _)
@@ -261,18 +262,18 @@ checkGroup inst_env clss@((ClassP cls _, _) : _)
 
        -- NOTE that we iterate over the fds first; they are typically
        -- empty, which aborts the rest of the loop.
-    pairwise_eqns :: [(Equation,SDoc)]
+    pairwise_eqns :: [(Equation,Pred_Loc,Pred_Loc)]
     pairwise_eqns      -- This group comes from pairwise comparison
-      = [ (eqn, mkEqnMsg p1 p2)
+      = [ (eqn, p1, p2)
        | fd <- cls_fds,
          p1@(ClassP _ tys1, _) : rest <- tails clss,
          p2@(ClassP _ tys2, _) <- rest,
          eqn <- checkClsFD emptyVarSet fd cls_tvs tys1 tys2
        ]
 
-    instance_eqns :: [(Equation,SDoc)]
+    instance_eqns :: [(Equation,Pred_Loc,Pred_Loc)]
     instance_eqns      -- This group comes from comparing with instance decls
-      = [ (eqn, mkEqnMsg p1 p2)
+      = [ (eqn, p1, p2)
        | fd <- cls_fds,        -- Iterate through the fundeps first, 
                                -- because there often are none!
          p2@(ClassP _ tys2, _) <- clss,
@@ -285,12 +286,6 @@ checkGroup inst_env clss@((ClassP cls _, _) : _)
                    ptext SLIT("arising from the instance declaration at") <+> 
                        ppr (getSrcLoc ispec))
        ]
-
-mkEqnMsg (pred1,from1) (pred2,from2)
-  = vcat [ptext SLIT("When using functional dependencies to combine"),
-         nest 2 (sep [ppr pred1 <> comma, nest 2 from1]), 
-         nest 2 (sep [ppr pred2 <> comma, nest 2 from2])]
- 
 ----------
 checkClsFD :: TyVarSet                         -- Quantified type variables; see note below
           -> FunDep TyVar -> [TyVar]   -- One functional dependency from the class