Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : ghc-7.2
http://hackage.haskell.org/trac/ghc/changeset/b72f0df964f4c52d0e0a4ca68ea8b5e58d5dea5b >--------------------------------------------------------------- commit b72f0df964f4c52d0e0a4ca68ea8b5e58d5dea5b Author: Simon Peyton Jones <[email protected]> Date: Fri Jul 15 14:46:13 2011 +0100 Fix error reporting for overlapping instances in type checker See #5320 and discussion there. This patch only removes a bogus assertion failure and refactors the code slightly. There's still an underlying delicate point, described in #5320. >--------------------------------------------------------------- compiler/typecheck/TcErrors.lhs | 40 ++++++++++++++++---------------------- 1 files changed, 17 insertions(+), 23 deletions(-) diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index b7b0151..6622af9 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -29,6 +29,7 @@ import VarEnv import SrcLoc import Bag import ListSetOps( equivClasses ) +import Maybes( mapCatMaybes ) import Util import FastString import Outputable @@ -555,13 +556,8 @@ reportOverlap ctxt inst_envs orig pred@(ClassP clas tys) ; case lookupInstEnv inst_envs clas tys_flat of ([], _, _) -> return (Just pred) -- No match - -- The case of exactly one match and no unifiers means a - -- successful lookup. That can't happen here, because dicts - -- only end up here if they didn't match in Inst.lookupInst - ([_],[], _) - | debugIsOn -> pprPanic "check_overlap" (ppr pred) - res -> do { addErrorReport ctxt (mk_overlap_msg res) - ; return Nothing } } + res -> do { addErrorReport ctxt (mk_overlap_msg res) + ; return Nothing } } where -- Normal overlap error mk_overlap_msg (matches, unifiers, False) @@ -571,15 +567,20 @@ reportOverlap ctxt inst_envs orig pred@(ClassP clas tys) , sep [ptext (sLit "Matching instances") <> colon, nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])] - , if not (null overlapping_givens) then - sep [ptext (sLit "Matching givens (or their superclasses)") <> colon, nest 2 (vcat overlapping_givens)] + , if not (null matching_givens) then + sep [ptext (sLit "Matching givens (or their superclasses)") <> colon + , nest 2 (vcat matching_givens)] else empty - , if null overlapping_givens && isSingleton matches && null unifiers then - -- Intuitively, some given matched the wanted in their flattened or rewritten (from given equalities) - -- form but the matcher can't figure that out because the constraints are non-flat and non-rewritten - -- so we simply report back the whole given context. Accelerate Smart.hs showed this problem. - sep [ptext (sLit "There exists a (perhaps superclass) match") <> colon, nest 2 (vcat (pp_givens givens))] + , if null matching_givens && isSingleton matches && null unifiers then + -- Intuitively, some given matched the wanted in their + -- flattened or rewritten (from given equalities) form + -- but the matcher can't figure that out because the + -- constraints are non-flat and non-rewritten so we + -- simply report back the whole given + -- context. Accelerate Smart.hs showed this problem. + sep [ ptext (sLit "There exists a (perhaps superclass) match") <> colon + , nest 2 (vcat (pp_givens givens))] else empty , if not (isSingleton matches) @@ -589,7 +590,7 @@ reportOverlap ctxt inst_envs orig pred@(ClassP clas tys) ASSERT( not (null unifiers) ) parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+> quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))), - if null (overlapping_givens) then + if null (matching_givens) then vcat [ ptext (sLit "To pick the first instance above, use -XIncoherentInstances"), ptext (sLit "when compiling the other instance declarations")] else empty])] @@ -597,14 +598,7 @@ reportOverlap ctxt inst_envs orig pred@(ClassP clas tys) ispecs = [ispec | (ispec, _) <- matches] givens = getUserGivens ctxt - overlapping_givens = unifiable_givens givens - - unifiable_givens [] = [] - unifiable_givens (gg:ggs) - | Just ggdoc <- matchable gg - = ggdoc : unifiable_givens ggs - | otherwise - = unifiable_givens ggs + matching_givens = mapCatMaybes matchable givens matchable (evvars,gloc) = case ev_vars_matching of _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
