Commit f493bc7c authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

Improve name-printing on unification mis-matches, when types share a common occurrence name

This improvement arose from a suggestion in Trac #1465
parent ed2f8e2a
......@@ -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}
......
......@@ -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
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment