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

This improvement arose from a suggestion in Trac #1465

diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index fb8e87e..b353caa 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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