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
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
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
= 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 }
import Name (nameOccName)
import OccName (pprOccName)
+import Data.Maybe
import Control.Exception
import Data.List
import Control.Monad
++ 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 []
getModuleInfo,
modInfoTyThings,
modInfoTopLevelScope,
- modInfoPrintUnqualified,
- modInfoExports,
+ modInfoExports,
modInfoInstances,
modInfoIsExportedName,
modInfoLookupName,
lookupGlobalName,
+ mkPrintUnqualifiedForModule,
-- * Printing
PrintUnqualified, alwaysQualify,
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 {
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
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
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,
import UniqSupply ( UniqSupply )
import FastString ( FastString )
import StringBuffer ( StringBuffer )
+import Util
import System.Time ( ClockTime )
import Data.IORef
#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
%* *
%************************************************************************
+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
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}
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
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)
= 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) }
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) }
-- 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}
BindingSite(..),
- PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify,
+ PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, QualifyName(..),
getPprStyle, withPprStyle, withPprStyleDoc,
pprDeeper, pprDeeperList, pprSetDepth,
codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
-- 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)
\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
projects / ghc-hetmet.git / commitdiff