From f493bc7c7325a3809dda3637c12e5d9383ba8117 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Fri, 29 Jun 2007 11:48:33 +0000 Subject: [PATCH] Improve name-printing on unification mis-matches, when types share a common occurrence name This improvement arose from a suggestion in Trac #1465 --- compiler/main/HscTypes.lhs | 32 +++++++++++++--------- compiler/typecheck/TcType.lhs | 15 ++++++----- compiler/typecheck/TcUnify.lhs | 58 +++++++++++++++++++++++++++------------- 3 files changed, 68 insertions(+), 37 deletions(-) diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index fb8e87e..b353caa 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -78,8 +78,8 @@ import {-# SOURCE #-} InteractiveEval ( Resume ) #endif import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv, GlobalRdrElt(..), - unQualOK, ImpDeclSpec(..), Provenance(..), - ImportSpec(..), lookupGlobalRdrEnv ) + mkRdrUnqual, ImpDeclSpec(..), Provenance(..), + ImportSpec(..), lookupGlobalRdrEnv, lookupGRE_RdrName ) import Name ( Name, NamedThing, getName, nameOccName, nameModule ) import NameEnv import NameSet @@ -115,7 +115,6 @@ import SrcLoc ( SrcSpan, Located ) import UniqFM ( lookupUFM, eltsUFM, emptyUFM ) import UniqSupply ( UniqSupply ) import FastString ( FastString ) - import StringBuffer ( StringBuffer ) import System.Time ( ClockTime ) @@ -701,19 +700,28 @@ extendInteractiveContext ictxt ids tyvars mkPrintUnqualified :: GlobalRdrEnv -> PrintUnqualified mkPrintUnqualified env = (qual_name, qual_mod) where - qual_name mod occ - | null gres = Just (moduleName mod) + qual_name mod occ -- The (mod,occ) pair is the original name of the thing + | [gre] <- unqual_gres, right_name gre = Nothing + -- If there's a unique entity that's in scope unqualified with 'occ' + -- AND that entity is the right one, then we can use the unqualified name + + | [gre] <- qual_gres = Just (get_qual_mod (gre_prov gre)) + + | null qual_gres = Just (moduleName mod) -- it isn't in scope at all, this probably shouldn't happen, -- but we'll qualify it by the original module anyway. - | any unQualOK gres = Nothing - | (Imported is : _) <- map gre_prov gres, (idecl : _) <- is - = Just (is_as (is_decl idecl)) - | otherwise = panic "mkPrintUnqualified" + + | otherwise = panic "mkPrintUnqualified" where - gres = [ gre | gre <- lookupGlobalRdrEnv env occ, - nameModule (gre_name gre) == mod ] + right_name gre = nameModule (gre_name gre) == mod + + unqual_gres = lookupGRE_RdrName (mkRdrUnqual occ) env + qual_gres = filter right_name (lookupGlobalRdrEnv env occ) + + get_qual_mod LocalDef = moduleName mod + get_qual_mod (Imported is) = ASSERT( not (null is) ) is_as (is_decl (head is)) - qual_mod mod = Nothing -- For now... + qual_mod mod = Nothing -- For now, we never qualify module names with their packages \end{code} diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index 01796c3..56351d7 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -442,17 +442,18 @@ pprSkolTvBinding :: TcTyVar -> SDoc -- or nothing if we don't have anything useful to say pprSkolTvBinding tv = ASSERT ( isTcTyVar tv ) - ppr_details (tcTyVarDetails tv) + quotes (ppr tv) <+> ppr_details (tcTyVarDetails tv) where - ppr_details (MetaTv TauTv _) = quotes (ppr tv) <+> ptext SLIT("is a meta type variable") - ppr_details (MetaTv BoxTv _) = quotes (ppr tv) <+> ptext SLIT("is a boxy type variable") + ppr_details (MetaTv TauTv _) = ptext SLIT("is a meta type variable") + ppr_details (MetaTv BoxTv _) = ptext SLIT("is a boxy type variable") ppr_details (MetaTv (SigTv info) _) = ppr_skol info ppr_details (SkolemTv info) = ppr_skol info - ppr_skol UnkSkol = empty -- Unhelpful; omit - ppr_skol RuntimeUnkSkol = quotes (ppr tv) <+> ptext SLIT("is an unknown runtime type") - ppr_skol info = quotes (ppr tv) <+> ptext SLIT("is bound by") - <+> sep [pprSkolInfo info, nest 2 (ptext SLIT("at") <+> ppr (getSrcLoc tv))] + ppr_skol UnkSkol = empty -- Unhelpful; omit + ppr_skol RuntimeUnkSkol = ptext SLIT("is an unknown runtime type") + ppr_skol info = ptext SLIT("is a rigid type variable bound by") + <+> sep [pprSkolInfo info, + nest 2 (ptext SLIT("at") <+> ppr (getSrcLoc tv))] pprSkolInfo :: SkolemInfo -> SDoc pprSkolInfo (SigSkol ctxt) = pprUserTypeCtxt ctxt diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index b2782d6..2b42d0b 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -44,6 +44,7 @@ import TysWiredIn import Var import VarSet import VarEnv +import Module import Name import ErrUtils import Maybes @@ -1584,31 +1585,52 @@ unifyMisMatch outer swapped ty1 ty2 else failWithTcM (env, msg) } +----------------------- +misMatchMsg :: TcType -> TcType -> TcM (TidyEnv, SDoc) +-- Generate the message when two types fail to match, +-- going to some trouble to make it helpful misMatchMsg ty1 ty2 = do { env0 <- tcInitTidyEnv - ; (env1, pp1, extra1) <- ppr_ty env0 ty1 - ; (env2, pp2, extra2) <- ppr_ty env1 ty2 + ; (env1, pp1, extra1) <- ppr_ty env0 ty1 ty2 + ; (env2, pp2, extra2) <- ppr_ty env1 ty2 ty1 ; return (env2, sep [sep [ptext SLIT("Couldn't match expected type") <+> pp1, nest 7 (ptext SLIT("against inferred type") <+> pp2)], - nest 2 extra1, nest 2 extra2]) } - -ppr_ty :: TidyEnv -> TcType -> TcM (TidyEnv, SDoc, SDoc) -ppr_ty env ty - = do { ty' <- zonkTcType ty - ; let (env1,tidy_ty) = tidyOpenType env ty' - simple_result = (env1, quotes (ppr tidy_ty), empty) - ; case tidy_ty of - TyVarTy tv - | isSkolemTyVar tv || isSigTyVar tv - -> return (env2, pp_rigid tv', pprSkolTvBinding tv') - | otherwise -> return simple_result - where - (env2, tv') = tidySkolemTyVar env1 tv - other -> return simple_result } + nest 2 (extra1 $$ extra2)]) } + +ppr_ty :: TidyEnv -> TcType -> TcType -> TcM (TidyEnv, SDoc, SDoc) +ppr_ty env ty other_ty + = do { ty' <- zonkTcType ty + ; let (env1, tidy_ty) = tidyOpenType env ty' + ; (env2, extra) <- ppr_extra env1 ty' other_ty + ; return (env2, quotes (ppr tidy_ty), extra) } + +-- (ppr_extra env ty other_ty) shows extra info about 'ty' +ppr_extra env (TyVarTy tv) other_ty + | isSkolemTyVar tv || isSigTyVar tv + = return (env1, pprSkolTvBinding tv1) where - pp_rigid tv = quotes (ppr tv) <+> parens (ptext SLIT("a rigid variable")) + (env1, tv1) = tidySkolemTyVar env tv + +ppr_extra env (TyConApp tc1 _) (TyConApp tc2 _) + | getOccName tc1 == getOccName tc2 + = -- This case helps with messages that would otherwise say + -- Could not match 'T' does not match 'M.T' + -- which is not helpful + do { this_mod <- getModule + ; return (env, quotes (ppr tc1) <+> ptext SLIT("is defined in") <+> mk_mod this_mod) } + where + tc_mod = nameModule (getName tc1) + tc_pkg = modulePackageId tc_mod + mk_mod this_mod + | tc_mod == this_mod = ptext SLIT("this module") + | otherwise = ptext SLIT("module") <+> quotes (ppr tc_mod) <+> mk_pkg this_mod + mk_pkg this_mod + | tc_pkg == modulePackageId this_mod = empty + | otherwise = ptext SLIT("from package") <+> quotes (ppr tc_pkg) +ppr_extra env ty other_ty = return (env, empty) -- Normal case +----------------------- notMonoType ty = do { ty' <- zonkTcType ty ; env0 <- tcInitTidyEnv -- 1.7.10.4