Commit 42181975 authored by Simon Marlow's avatar Simon Marlow

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 <package>:<module>.<name> 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).
parent c02da7d1
......@@ -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
......
......@@ -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
......
......@@ -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 }
......
......@@ -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 []
......
......@@ -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
......
......@@ -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}
......
......@@ -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
......
......@@ -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) }
......
......@@ -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}
......@@ -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.
-- a package name to disambiguate it.
type QueryQualifyModule = Module -> Bool
type PrintUnqualified = (QueryQualifyName, QueryQualifyModule)
alwaysQualifyNames :: QualifyName
alwaysQualifyNames :: QueryQualifyName
alwaysQualifyNames m n = NameQual (moduleName m)
neverQualifyNames :: QualifyName
neverQualifyNames :: QueryQualifyName
neverQualifyNames m n = NameUnqual
alwaysQualifyModules :: QualifyModule
alwaysQualifyModules :: QueryQualifyModule
alwaysQualifyModules m = True
neverQualifyModules :: QualifyModule
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
......
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