From 421819753b3eb4940a26e578ef0e4c5cd31761fa Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Thu, 6 Sep 2007 09:37:44 +0000 Subject: [PATCH] FIX #1465, error messages could sometimes say things like "A.T doesn't match A.T" This turned out to be a black hole, however we believe we now have a plan that does the right thing and shouldn't need to change again. Error messages will only ever refer to a name in an unambiguous way, falling back to :. if no unambiguous shorter variant can be found. See HscTypes.mkPrintUnqualified for the details. Earlier hacks to work around this problem have been removed (TcSimplify). --- compiler/basicTypes/Module.lhs | 2 +- compiler/basicTypes/Name.lhs | 8 +++-- compiler/deSugar/DsMonad.lhs | 13 ++++---- compiler/ghci/GhciTags.hs | 13 +++++--- compiler/main/GHC.hs | 12 ++++--- compiler/main/HscTypes.lhs | 66 +++++++++++++++++++++++++++++-------- compiler/rename/RnNames.lhs | 3 +- compiler/typecheck/TcRnMonad.lhs | 9 +++-- compiler/typecheck/TcSimplify.lhs | 45 +++++++------------------ compiler/utils/Outputable.lhs | 46 ++++++++++++++++---------- 10 files changed, 128 insertions(+), 89 deletions(-) diff --git a/compiler/basicTypes/Module.lhs b/compiler/basicTypes/Module.lhs index ece181a..0a1c4a5 100644 --- a/compiler/basicTypes/Module.lhs +++ b/compiler/basicTypes/Module.lhs @@ -201,7 +201,7 @@ pprPackagePrefix p mod = getPprStyle doc if p == mainPackageId then empty -- never qualify the main package in code else ftext (zEncodeFS (packageIdFS p)) <> char '_' - | Just pkg <- qualModule sty mod = ftext (packageIdFS pkg) <> char ':' + | qualModule sty mod = ftext (packageIdFS (modulePackageId mod)) <> char ':' -- the PrintUnqualified tells us which modules have to -- be qualified with package names | otherwise = empty diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs index 8615599..488dbca 100644 --- a/compiler/basicTypes/Name.lhs +++ b/compiler/basicTypes/Name.lhs @@ -367,9 +367,13 @@ pprExternal sty uniq mod occ is_wired is_builtin pprUnique uniq]) | BuiltInSyntax <- is_builtin = ppr_occ_name occ -- never qualify builtin syntax - | Just mod <- qualName sty mod occ = ppr mod <> dot <> ppr_occ_name occ - -- the PrintUnqualified tells us how to qualify this Name, if at all + | NameQual modname <- qual_name = ppr modname <> dot <> ppr_occ_name occ + -- see HscTypes.mkPrintUnqualified and Outputable.QualifyName: + | NameNotInScope1 <- qual_name = ppr mod <> dot <> ppr_occ_name occ + | NameNotInScope2 <- qual_name = ppr (modulePackageId mod) <> char ':' <> + ppr (moduleName mod) <> dot <> ppr_occ_name occ | otherwise = ppr_occ_name occ + where qual_name = qualName sty mod occ pprInternal sty uniq occ | codeStyle sty = pprUnique uniq diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs index 7af0755..e47cd57 100644 --- a/compiler/deSugar/DsMonad.lhs +++ b/compiler/deSugar/DsMonad.lhs @@ -170,14 +170,14 @@ initDs :: HscEnv initDs hsc_env mod rdr_env type_env thing_inside = do { msg_var <- newIORef (emptyBag, emptyBag) - ; (ds_gbl_env, ds_lcl_env) <- mkDsEnvs mod rdr_env type_env msg_var + ; let dflags = hsc_dflags hsc_env + ; (ds_gbl_env, ds_lcl_env) <- mkDsEnvs dflags mod rdr_env type_env msg_var ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $ tryM thing_inside -- Catch exceptions (= errors during desugaring) -- Display any errors and warnings -- Note: if -Werror is used, we don't signal an error here. - ; let dflags = hsc_dflags hsc_env ; msgs <- readIORef msg_var ; printErrorsAndWarnings dflags msgs @@ -196,20 +196,21 @@ initDsTc thing_inside = do { this_mod <- getModule ; tcg_env <- getGblEnv ; msg_var <- getErrsVar + ; dflags <- getDOpts ; let type_env = tcg_type_env tcg_env rdr_env = tcg_rdr_env tcg_env - ; ds_envs <- ioToIOEnv$ mkDsEnvs this_mod rdr_env type_env msg_var + ; ds_envs <- ioToIOEnv$ mkDsEnvs dflags this_mod rdr_env type_env msg_var ; setEnvs ds_envs thing_inside } -mkDsEnvs :: Module -> GlobalRdrEnv -> TypeEnv -> IORef Messages -> IO (DsGblEnv, DsLclEnv) -mkDsEnvs mod rdr_env type_env msg_var +mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> IORef Messages -> IO (DsGblEnv, DsLclEnv) +mkDsEnvs dflags mod rdr_env type_env msg_var = do sites_var <- newIORef [] let if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) } if_lenv = mkIfLclEnv mod (ptext SLIT("GHC error in desugarer lookup in") <+> ppr mod) gbl_env = DsGblEnv { ds_mod = mod, ds_if_env = (if_genv, if_lenv), - ds_unqual = mkPrintUnqualified rdr_env, + ds_unqual = mkPrintUnqualified dflags rdr_env, ds_msgs = msg_var} lcl_env = DsLclEnv { ds_meta = emptyNameEnv, ds_loc = noSrcSpan } diff --git a/compiler/ghci/GhciTags.hs b/compiler/ghci/GhciTags.hs index 1c5295a..a974c01 100644 --- a/compiler/ghci/GhciTags.hs +++ b/compiler/ghci/GhciTags.hs @@ -25,6 +25,7 @@ import Util import Name (nameOccName) import OccName (pprOccName) +import Data.Maybe import Control.Exception import Data.List import Control.Monad @@ -69,11 +70,13 @@ createTagsFile session tagskind tagFile = do ++ GHC.moduleNameString (GHC.moduleName m) ++ "' is not interpreted")) mbModInfo <- GHC.getModuleInfo session m - let unqual - | Just modinfo <- mbModInfo, - Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual - | otherwise = GHC.alwaysQualify - + unqual <- + case mbModInfo of + Just minf -> do + mb_print_unqual <- GHC.mkPrintUnqualifiedForModule session minf + return (fromMaybe GHC.alwaysQualify mb_print_unqual) + Nothing -> + return GHC.alwaysQualify case mbModInfo of Just modInfo -> return $! listTags unqual modInfo _ -> return [] diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 047781e..1656e1c 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -57,12 +57,12 @@ module GHC ( getModuleInfo, modInfoTyThings, modInfoTopLevelScope, - modInfoPrintUnqualified, - modInfoExports, + modInfoExports, modInfoInstances, modInfoIsExportedName, modInfoLookupName, lookupGlobalName, + mkPrintUnqualifiedForModule, -- * Printing PrintUnqualified, alwaysQualify, @@ -1809,7 +1809,8 @@ getBindings s = withSession s $ \hsc_env -> return filtered getPrintUnqual :: Session -> IO PrintUnqualified -getPrintUnqual s = withSession s (return . icPrintUnqual . hsc_IC) +getPrintUnqual s = withSession s $ \hsc_env -> + return (icPrintUnqual (hsc_dflags hsc_env) (hsc_IC hsc_env)) -- | Container for information about a 'Module'. data ModuleInfo = ModuleInfo { @@ -1902,8 +1903,9 @@ modInfoInstances = minf_instances modInfoIsExportedName :: ModuleInfo -> Name -> Bool modInfoIsExportedName minf name = elemNameSet name (minf_exports minf) -modInfoPrintUnqualified :: ModuleInfo -> Maybe PrintUnqualified -modInfoPrintUnqualified minf = fmap mkPrintUnqualified (minf_rdr_env minf) +mkPrintUnqualifiedForModule :: Session -> ModuleInfo -> IO (Maybe PrintUnqualified) +mkPrintUnqualifiedForModule s minf = withSession s $ \hsc_env -> do + return (fmap (mkPrintUnqualified (hsc_dflags hsc_env)) (minf_rdr_env minf)) modInfoLookupName :: Session -> ModuleInfo -> Name -> IO (Maybe TyThing) modInfoLookupName s minf name = withSession s $ \hsc_env -> do diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index ea8ed64..34d4e02 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -85,9 +85,7 @@ import ByteCodeAsm ( CompiledByteCode ) import {-# SOURCE #-} InteractiveEval ( Resume ) #endif -import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv, GlobalRdrElt(..), - mkRdrUnqual, ImpDeclSpec(..), Provenance(..), - ImportSpec(..), lookupGlobalRdrEnv, lookupGRE_RdrName ) +import RdrName import Name ( Name, NamedThing, getName, nameOccName, nameModule ) import NameEnv import NameSet @@ -108,7 +106,7 @@ import Class ( Class, classSelIds, classATs, classTyCon ) import TyCon import DataCon ( DataCon, dataConImplicitIds ) import PrelNames ( gHC_PRIM ) -import Packages ( PackageId ) +import Packages hiding ( Version(..) ) import DynFlags ( DynFlags(..), isOneShot, HscTarget (..) ) import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, Phase ) import BasicTypes ( Version, initialVersion, IPName, @@ -124,6 +122,7 @@ import UniqFM ( lookupUFM, eltsUFM, emptyUFM ) import UniqSupply ( UniqSupply ) import FastString ( FastString ) import StringBuffer ( StringBuffer ) +import Util import System.Time ( ClockTime ) import Data.IORef @@ -691,8 +690,8 @@ emptyInteractiveContext #endif } -icPrintUnqual :: InteractiveContext -> PrintUnqualified -icPrintUnqual ictxt = mkPrintUnqualified (ic_rn_gbl_env ictxt) +icPrintUnqual :: DynFlags -> InteractiveContext -> PrintUnqualified +icPrintUnqual dflags ictxt = mkPrintUnqualified dflags (ic_rn_gbl_env ictxt) extendInteractiveContext @@ -729,20 +728,44 @@ substInteractiveContext ictxt@InteractiveContext{ic_tmp_ids=ids} subst = %* * %************************************************************************ +Deciding how to print names is pretty tricky. We are given a name +P:M.T, where P is the package name, M is the defining module, and T is +the occurrence name, and we have to decide in which form to display +the name given a GlobalRdrEnv describing the current scope. + +Ideally we want to display the name in the form in which it is in +scope. However, the name might not be in scope at all, and that's +where it gets tricky. Here are the cases: + + 1. T uniquely maps to P:M.T ---> "T" + 2. there is an X for which X.T uniquely maps to P:M.T ---> "X.T" + 3. there is no binding for "M.T" ---> "M.T" + 4. otherwise ---> "P:M.T" + +3 and 4 apply when P:M.T is not in scope. In these cases we want to +refer to the name as "M.T", but "M.T" might mean something else in the +current scope (e.g. if there's an "import X as M"), so to avoid +confusion we avoid using "M.T" if there's already a binding for it. + +There's one further subtlety: if the module M cannot be imported +because it is not exposed by any package, then we must refer to it as +"P:M". This is handled by the qual_mod component of PrintUnqualified. + \begin{code} -mkPrintUnqualified :: GlobalRdrEnv -> PrintUnqualified -mkPrintUnqualified env = (qual_name, qual_mod) +mkPrintUnqualified :: DynFlags -> GlobalRdrEnv -> PrintUnqualified +mkPrintUnqualified dflags env = (qual_name, qual_mod) where qual_name mod occ -- The (mod,occ) pair is the original name of the thing - | [gre] <- unqual_gres, right_name gre = Nothing + | [gre] <- unqual_gres, right_name gre = NameUnqual -- 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)) + | [gre] <- qual_gres = NameQual (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. + | null qual_gres = + if null (lookupGRE_RdrName (mkRdrQual (moduleName mod) occ) env) + then NameNotInScope1 + else NameNotInScope2 | otherwise = panic "mkPrintUnqualified" where @@ -754,7 +777,22 @@ mkPrintUnqualified env = (qual_name, qual_mod) 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, we never qualify module names with their packages + -- we can mention a module P:M without the P: qualifier iff + -- "import M" would resolve unambiguously to P:M. (if P is the + -- current package we can just assume it is unqualified). + + qual_mod mod + | modulePackageId mod == thisPackage dflags = False + + | [pkgconfig] <- [pkg | (pkg,exposed_module) <- lookup, + exposed pkg && exposed_module], + packageConfigId pkgconfig == modulePackageId mod + -- this says: we are given a module P:M, is there just one exposed package + -- that exposes a module M, and is it package P? + = False + + | otherwise = True + where lookup = lookupModuleInAllPackages dflags (moduleName mod) \end{code} diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 8c09894..8f24141 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -1254,8 +1254,9 @@ printMinimalImports imps mod_ies <- initIfaceTcRn $ mappM to_ies (fmToList imps) ; this_mod <- getModule ; rdr_env <- getGlobalRdrEnv ; + dflags <- getDOpts ; ioToTcRn (do { h <- openFile (mkFilename this_mod) WriteMode ; - printForUser h (mkPrintUnqualified rdr_env) + printForUser h (mkPrintUnqualified dflags rdr_env) (vcat (map ppr_mod_ie mod_ies)) }) } where diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 33c6aec..c7c51ed 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -369,7 +369,8 @@ traceOptTcRn flag doc = ifOptM flag $ do dumpTcRn :: SDoc -> TcRn () dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ; - ioToTcRn (printForUser stderr (mkPrintUnqualified rdr_env) doc) } + dflags <- getDOpts ; + ioToTcRn (printForUser stderr (mkPrintUnqualified dflags rdr_env) doc) } dumpOptTcRn :: DynFlag -> SDoc -> TcRn () dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc) @@ -475,7 +476,8 @@ addLongErrAt loc msg extra = do { traceTc (ptext SLIT("Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ; errs_var <- getErrsVar ; rdr_env <- getGlobalRdrEnv ; - let { err = mkLongErrMsg loc (mkPrintUnqualified rdr_env) msg extra } ; + dflags <- getDOpts ; + let { err = mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } ; (warns, errs) <- readMutVar errs_var ; writeMutVar errs_var (warns, errs `snocBag` err) } @@ -491,7 +493,8 @@ addReportAt :: SrcSpan -> Message -> TcRn () addReportAt loc msg = do { errs_var <- getErrsVar ; rdr_env <- getGlobalRdrEnv ; - let { warn = mkWarnMsg loc (mkPrintUnqualified rdr_env) msg } ; + dflags <- getDOpts ; + let { warn = mkWarnMsg loc (mkPrintUnqualified dflags rdr_env) msg } ; (warns, errs) <- readMutVar errs_var ; writeMutVar errs_var (warns `snocBag` warn, errs) } diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 62a7151..fa5c677 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -3085,51 +3085,28 @@ misMatchMsg :: TcType -> TcType -> TcM (TidyEnv, SDoc) -- The argument order is: actual type, expected type misMatchMsg ty_act ty_exp = do { env0 <- tcInitTidyEnv - ; (env1, pp_exp, extra_exp) <- ppr_ty env0 ty_exp ty_act - ; (env2, pp_act, extra_act) <- ppr_ty env1 ty_act ty_exp + ; ty_exp <- zonkTcType ty_exp + ; ty_act <- zonkTcType ty_act + ; (env1, pp_exp, extra_exp) <- ppr_ty env0 ty_exp + ; (env2, pp_act, extra_act) <- ppr_ty env1 ty_act ; return (env2, sep [sep [ptext SLIT("Couldn't match expected type") <+> pp_exp, nest 7 $ ptext SLIT("against inferred type") <+> pp_act], nest 2 (extra_exp $$ extra_act)]) } -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 tidy_ty other_ty +ppr_ty :: TidyEnv -> TcType -> TcM (TidyEnv, SDoc, SDoc) +ppr_ty env ty + = do { let (env1, tidy_ty) = tidyOpenType env ty + ; (env2, extra) <- ppr_extra env1 tidy_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 +-- (ppr_extra env ty) shows extra info about 'ty' +ppr_extra env (TyVarTy tv) | isSkolemTyVar tv || isSigTyVar tv = return (env1, pprSkolTvBinding tv1) where (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") <+> mk_mod this_mod) } - where - tc_mod = nameModule (getName tc1) - tc_pkg = modulePackageId tc_mod - tc2_pkg = modulePackageId (nameModule (getName tc2)) - mk_mod this_mod - | tc_mod == this_mod = ptext SLIT("in this module") - - | not home_pkg && tc2_pkg /= tc_pkg = pp_pkg - -- Suppress the module name if (a) it's from another package - -- (b) other_ty isn't from that same package - - | otherwise = ptext SLIT("in module") <+> quotes (ppr tc_mod) <+> pp_pkg - where - home_pkg = tc_pkg == modulePackageId this_mod - pp_pkg | home_pkg = empty - | otherwise = ptext SLIT("in package") <+> quotes (ppr tc_pkg) - -ppr_extra env ty other_ty = return (env, empty) -- Normal case +ppr_extra env ty = return (env, empty) -- Normal case \end{code} diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index 2462ea2..2bf1b9c 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -19,7 +19,7 @@ module Outputable ( BindingSite(..), - PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, + PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, QualifyName(..), getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper, pprDeeperList, pprSetDepth, codeStyle, userStyle, debugStyle, dumpStyle, asmStyle, @@ -121,26 +121,36 @@ data Depth = AllTheWay -- as @Exception.catch@, this fuction will return @Just "Exception"@. -- Note that the return value is a ModuleName, not a Module, because -- in source code, names are qualified by ModuleNames. -type QualifyName = Module -> OccName -> Maybe ModuleName +type QueryQualifyName = Module -> OccName -> QualifyName + +data QualifyName -- given P:M.T + = NameUnqual -- refer to it as "T" + | NameQual ModuleName -- refer to it as "X.T" for the supplied X + | NameNotInScope1 + -- it is not in scope at all, but M.T is not bound in the current + -- scope, so we can refer to it as "M.T" + | NameNotInScope2 + -- it is not in scope at all, and M.T is already bound in the + -- current scope, so we must refer to it as "P:M.T" + -- | For a given module, we need to know whether to print it with --- a package name to disambiguate it, and if so which package name should --- we use. -type QualifyModule = Module -> Maybe PackageId +-- a package name to disambiguate it. +type QueryQualifyModule = Module -> Bool -type PrintUnqualified = (QualifyName, QualifyModule) +type PrintUnqualified = (QueryQualifyName, QueryQualifyModule) -alwaysQualifyNames :: QualifyName -alwaysQualifyNames m n = Just (moduleName m) +alwaysQualifyNames :: QueryQualifyName +alwaysQualifyNames m n = NameQual (moduleName m) -neverQualifyNames :: QualifyName -neverQualifyNames m n = Nothing +neverQualifyNames :: QueryQualifyName +neverQualifyNames m n = NameUnqual -alwaysQualifyModules :: QualifyModule -alwaysQualifyModules m = Just (modulePackageId m) +alwaysQualifyModules :: QueryQualifyModule +alwaysQualifyModules m = True -neverQualifyModules :: QualifyModule -neverQualifyModules m = Nothing +neverQualifyModules :: QueryQualifyModule +neverQualifyModules m = False alwaysQualify = (alwaysQualifyNames, alwaysQualifyModules) neverQualify = (neverQualifyNames, neverQualifyModules) @@ -217,13 +227,13 @@ getPprStyle df sty = df sty sty \end{code} \begin{code} -qualName :: PprStyle -> QualifyName +qualName :: PprStyle -> QueryQualifyName qualName (PprUser (qual_name,_) _) m n = qual_name m n -qualName other m n = Just (moduleName m) +qualName other m n = NameQual (moduleName m) -qualModule :: PprStyle -> QualifyModule +qualModule :: PprStyle -> QueryQualifyModule qualModule (PprUser (_,qual_mod) _) m = qual_mod m -qualModule other m = Just (modulePackageId m) +qualModule other m = True codeStyle :: PprStyle -> Bool codeStyle (PprCode _) = True -- 1.7.10.4