Commit 66218d15 authored by Edward Z. Yang's avatar Edward Z. Yang

Package keys (for linking/type equality) separated from package IDs.

This patch set makes us no longer assume that a package key is a human
readable string, leaving Cabal free to "do whatever it wants" to allocate
keys; we'll look up the PackageId in the database to display to the user.
This also means we have a new level of qualifier decisions to make at the
package level, and rewriting some Safe Haskell error reporting code to DTRT.

Additionally, we adjust the build system to use a new ghc-cabal output
Make variable PACKAGE_KEY to determine library names and other things,
rather than concatenating PACKAGE/VERSION as before.

Adds a new `-this-package-key` flag to subsume the old, erroneously named
`-package-name` flag, and `-package-key` to select packages by package key.

RFC: The md5 hashes are pretty tough on the eye, as far as the file
system is concerned :(

ToDo: safePkg01 test had its output updated, but the fix is not really right:
the rest of the dependencies are truncated due to the fact the we're only
grepping a single line, but ghc-pkg is wrapping its output.

ToDo: In a later commit, update all submodules to stop using -package-name
and use -this-package-key.  For now, we don't do it to avoid submodule
explosion.
Signed-off-by: default avatarEdward Z. Yang <ezyang@cs.stanford.edu>

Test Plan: validate

Reviewers: simonpj, simonmar, hvr, austin

Subscribers: simonmar, relrod, carter

Differential Revision: https://phabricator.haskell.org/D80
parent edff1efa
......@@ -43,6 +43,7 @@ module Module
mainPackageKey,
thisGhcPackageKey,
interactivePackageKey, isInteractiveModule,
wiredInPackageKeys,
-- * The Module type
Module,
......@@ -82,6 +83,7 @@ import UniqFM
import FastString
import Binary
import Util
import {-# SOURCE #-} Packages
import Data.Data
import Data.Map (Map)
......@@ -274,7 +276,7 @@ pprPackagePrefix p mod = getPprStyle doc
if p == mainPackageKey
then empty -- never qualify the main package in code
else ztext (zEncodeFS (packageKeyFS p)) <> char '_'
| qualModule sty mod = ftext (packageKeyFS (modulePackageKey mod)) <> char ':'
| qualModule sty mod = ppr (modulePackageKey mod) <> char ':'
-- the PrintUnqualified tells us which modules have to
-- be qualified with package names
| otherwise = empty
......@@ -293,7 +295,10 @@ class HasModule m where
%************************************************************************
\begin{code}
-- | Essentially just a string identifying a package, including the version: e.g. parsec-1.0
-- | A string which uniquely identifies a package. For wired-in packages,
-- it is just the package name, but for user compiled packages, it is a hash.
-- ToDo: when the key is a hash, we can do more clever things than store
-- the hex representation and hash-cons those strings.
newtype PackageKey = PId FastString deriving( Eq, Typeable )
-- here to avoid module loops with PackageConfig
......@@ -316,7 +321,12 @@ stablePackageKeyCmp :: PackageKey -> PackageKey -> Ordering
stablePackageKeyCmp p1 p2 = packageKeyFS p1 `compare` packageKeyFS p2
instance Outputable PackageKey where
ppr pid = text (packageKeyString pid)
ppr pk = getPprStyle $ \sty -> sdocWithDynFlags $ \dflags ->
text (packageKeyPackageIdString dflags pk)
-- Don't bother qualifying if it's wired in!
<> (if qualPackage sty pk && not (pk `elem` wiredInPackageKeys)
then char '@' <> ftext (packageKeyFS pk)
else empty)
instance Binary PackageKey where
put_ bh pid = put_ bh (packageKeyFS pid)
......@@ -377,6 +387,16 @@ mainPackageKey = fsToPackageKey (fsLit "main")
isInteractiveModule :: Module -> Bool
isInteractiveModule mod = modulePackageKey mod == interactivePackageKey
wiredInPackageKeys :: [PackageKey]
wiredInPackageKeys = [ primPackageKey,
integerPackageKey,
basePackageKey,
rtsPackageKey,
thPackageKey,
thisGhcPackageKey,
dphSeqPackageKey,
dphParPackageKey ]
\end{code}
%************************************************************************
......
......@@ -105,11 +105,11 @@ Library
Include-Dirs: . parser utils
if impl( ghc >= 7.9 )
-- We need to set the package name to ghc (without a version number)
-- We need to set the package key to ghc (without a version number)
-- as it's magic. But we can't set it for old versions of GHC (e.g.
-- when bootstrapping) because those versions of GHC don't understand
-- that GHC is wired-in.
GHC-Options: -package-name ghc
GHC-Options: -this-package-key ghc
if flag(stage1)
Include-Dirs: stage1
......
......@@ -437,8 +437,14 @@ ifeq "$(compiler_stage1_VERSION_MUNGED)" "YES"
compiler_stage1_MUNGED_VERSION = $(subst .$(ProjectPatchLevel),,$(ProjectVersion))
define compiler_PACKAGE_MAGIC
compiler_stage1_VERSION = $(compiler_stage1_MUNGED_VERSION)
compiler_stage1_PACKAGE_KEY = $(subst .$(ProjectPatchLevel),,$(compiler_stage1_PACKAGE_KEY))
endef
# NB: the PACKAGE_KEY munging has no effect for new-style package keys
# (which indeed, have nothing version like in them, but are important for
# old-style package keys which do.) The subst operation is idempotent, so
# as long as we do it at least once we should be good.
# Don't register the non-munged package
compiler_stage1_REGISTER_PACKAGE = NO
......
......@@ -70,7 +70,7 @@ import System.Directory hiding (findFile)
import System.Directory
#endif
import Distribution.Package hiding (depends)
import Distribution.Package hiding (depends, mkPackageKey, PackageKey)
import Exception
\end{code}
......
......@@ -876,6 +876,8 @@ badIfaceFile file err
hiModuleNameMismatchWarn :: Module -> Module -> MsgDoc
hiModuleNameMismatchWarn requested_mod read_mod =
-- ToDo: This will fail to have enough qualification when the package IDs
-- are the same
withPprStyle (mkUserStyle alwaysQualify AllTheWay) $
-- we want the Modules below to be qualified with package names,
-- so reset the PrintUnqualified setting.
......
......@@ -406,7 +406,7 @@ strDisplayName_llvm lbl = do
dflags <- getDynFlags
let sdoc = pprCLabel platform lbl
depth = Outp.PartWay 1
style = Outp.mkUserStyle (\ _ _ -> Outp.NameNotInScope2, Outp.alwaysQualifyModules) depth
style = Outp.mkUserStyle Outp.reallyAlwaysQualify depth
str = Outp.renderWithStyle dflags sdoc style
return (fsLit (dropInfoSuffix str))
......
......@@ -90,7 +90,7 @@ module DynFlags (
getVerbFlags,
updOptLevel,
setTmpDir,
setPackageName,
setPackageKey,
-- ** Parsing DynFlags
parseDynamicFlagsCmdLine,
......@@ -1023,6 +1023,7 @@ isNoLink _ = False
data PackageFlag
= ExposePackage String
| ExposePackageId String
| ExposePackageKey String
| HidePackage String
| IgnorePackage String
| TrustPackage String
......@@ -2526,9 +2527,13 @@ package_flags = [
removeUserPkgConf
deprecate "Use -no-user-package-db instead")
, Flag "package-name" (hasArg setPackageName)
, Flag "package-name" (HasArg $ \name -> do
upd (setPackageKey name)
deprecate "Use -this-package-key instead")
, Flag "this-package-key" (hasArg setPackageKey)
, Flag "package-id" (HasArg exposePackageId)
, Flag "package" (HasArg exposePackage)
, Flag "package-key" (HasArg exposePackageKey)
, Flag "hide-package" (HasArg hidePackage)
, Flag "hide-all-packages" (NoArg (setGeneralFlag Opt_HideAllPackages))
, Flag "ignore-package" (HasArg ignorePackage)
......@@ -3338,11 +3343,13 @@ removeGlobalPkgConf = upd $ \s -> s { extraPkgConfs = filter isNotGlobal . extra
clearPkgConf :: DynP ()
clearPkgConf = upd $ \s -> s { extraPkgConfs = const [] }
exposePackage, exposePackageId, hidePackage, ignorePackage,
exposePackage, exposePackageId, exposePackageKey, hidePackage, ignorePackage,
trustPackage, distrustPackage :: String -> DynP ()
exposePackage p = upd (exposePackage' p)
exposePackageId p =
upd (\s -> s{ packageFlags = ExposePackageId p : packageFlags s })
exposePackageKey p =
upd (\s -> s{ packageFlags = ExposePackageKey p : packageFlags s })
hidePackage p =
upd (\s -> s{ packageFlags = HidePackage p : packageFlags s })
ignorePackage p =
......@@ -3356,8 +3363,8 @@ exposePackage' :: String -> DynFlags -> DynFlags
exposePackage' p dflags
= dflags { packageFlags = ExposePackage p : packageFlags dflags }
setPackageName :: String -> DynFlags -> DynFlags
setPackageName p s = s{ thisPackage = stringToPackageKey p }
setPackageKey :: String -> DynFlags -> DynFlags
setPackageKey p s = s{ thisPackage = stringToPackageKey p }
-- If we're linking a binary, then only targets that produce object
-- code are allowed (requests for other target types are ignored).
......@@ -3600,6 +3607,7 @@ compilerInfo dflags
("Support dynamic-too", if isWindows then "NO" else "YES"),
("Support parallel --make", "YES"),
("Support reexported-modules", "YES"),
("Uses package keys", "YES"),
("Dynamic by default", if dYNAMIC_BY_DEFAULT dflags
then "YES" else "NO"),
("GHC Dynamic", if dynamicGhc
......
......@@ -43,7 +43,7 @@ import Maybes ( expectJust )
import Exception ( evaluate )
import Distribution.Text
import Distribution.Package
import Distribution.Package hiding (PackageKey, mkPackageKey)
import Data.IORef ( IORef, writeIORef, readIORef, atomicModifyIORef )
import System.Directory
import System.FilePath
......
......@@ -891,6 +891,13 @@ hscGetSafe hsc_env m l = runHsc hsc_env $ do
| otherwise = pkgs
return (good, pkgs')
-- | A function which only qualifies package names if necessary; but
-- qualifies all other identifiers.
pkgQual :: DynFlags -> PrintUnqualified
pkgQual dflags = alwaysQualify {
queryQualifyPackage = mkQualPackage dflags
}
-- | Is a module trusted? If not, throw or log errors depending on the type.
-- Return (regardless of trusted or not) if the trust type requires the modules
-- own package be trusted and a list of other packages required to be trusted
......@@ -932,13 +939,13 @@ hscCheckSafe' dflags m l = do
return (trust == Sf_Trustworthy, pkgRs)
where
pkgTrustErr = unitBag $ mkPlainErrMsg dflags l $
pkgTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $
sep [ ppr (moduleName m)
<> text ": Can't be safely imported!"
, text "The package (" <> ppr (modulePackageKey m)
<> text ") the module resides in isn't trusted."
]
modTrustErr = unitBag $ mkPlainErrMsg dflags l $
modTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $
sep [ ppr (moduleName m)
<> text ": Can't be safely imported!"
, text "The module itself isn't safe." ]
......@@ -995,7 +1002,7 @@ checkPkgTrust dflags pkgs =
| trusted $ getPackageDetails (pkgState dflags) pkg
= Nothing
| otherwise
= Just $ mkPlainErrMsg dflags noSrcSpan
= Just $ mkErrMsg dflags noSrcSpan (pkgQual dflags)
$ text "The package (" <> ppr pkg <> text ") is required" <>
text " to be trusted but it isn't!"
......
......@@ -54,6 +54,7 @@ module HscTypes (
setInteractivePrintName, icInteractiveModule,
InteractiveImport(..), setInteractivePackage,
mkPrintUnqualified, pprModulePrefix,
mkQualPackage, mkQualModule,
-- * Interfaces
ModIface(..), mkIfaceWarnCache, mkIfaceHashCache, mkIfaceFixCache,
......@@ -443,7 +444,7 @@ instance Outputable TargetId where
-- | Helps us find information about modules in the home package
type HomePackageTable = ModuleNameEnv HomeModInfo
-- Domain = modules in the home package that have been fully compiled
-- "home" package name cached here for convenience
-- "home" package key cached here for convenience
-- | Helps us find information about modules in the imported packages
type PackageIfaceTable = ModuleEnv ModIface
......@@ -1138,7 +1139,7 @@ The details are a bit tricky though:
extend the HPT.
* The 'thisPackage' field of DynFlags is *not* set to 'interactive'.
It stays as 'main' (or whatever -package-name says), and is the
It stays as 'main' (or whatever -this-package-key says), and is the
package to which :load'ed modules are added to.
* So how do we arrange that declarations at the command prompt get
......@@ -1148,7 +1149,7 @@ The details are a bit tricky though:
turn get the module from it 'icInteractiveModule' field of the
interactive context.
The 'thisPackage' field stays as 'main' (or whatever -package-name says.
The 'thisPackage' field stays as 'main' (or whatever -this-package-key says.
* The main trickiness is that the type environment (tcg_type_env and
fixity envt (tcg_fix_env), and instances (tcg_insts, tcg_fam_insts)
......@@ -1409,11 +1410,28 @@ exposed (say P2), so we use M.T for that, and P1:M.T for the other one.
This is handled by the qual_mod component of PrintUnqualified, inside
the (ppr mod) of case (3), in Name.pprModulePrefix
Note [Printing package keys]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In the old days, original names were tied to PackageIds, which directly
corresponded to the entities that users wrote in Cabal files, and were perfectly
suitable for printing when we need to disambiguate packages. However, with
PackageKey, the situation is different. First, the key is not a human readable
at all, so we need to consult the package database to find the appropriate
PackageId to display. Second, there may be multiple copies of a library visible
with the same PackageId, in which case we need to disambiguate. For now,
we just emit the actual package key (which the user can go look up); however,
another scheme is to (recursively) say which dependencies are different.
NB: When we extend package keys to also have holes, we will have to disambiguate
those as well.
\begin{code}
-- | Creates some functions that work out the best ways to format
-- names for the user according to a set of heuristics
-- names for the user according to a set of heuristics.
mkPrintUnqualified :: DynFlags -> GlobalRdrEnv -> PrintUnqualified
mkPrintUnqualified dflags env = (qual_name, qual_mod)
mkPrintUnqualified dflags env = QueryQualify qual_name
(mkQualModule dflags)
(mkQualPackage dflags)
where
qual_name mod occ
| [gre] <- unqual_gres
......@@ -1446,7 +1464,11 @@ mkPrintUnqualified dflags env = (qual_name, qual_mod)
-- "import M" would resolve unambiguously to P:M. (if P is the
-- current package we can just assume it is unqualified).
qual_mod mod
-- | Creates a function for formatting modules based on two heuristics:
-- (1) if the module is the current module, don't qualify, and (2) if there
-- is only one exposed package which exports this module, don't qualify.
mkQualModule :: DynFlags -> QueryQualifyModule
mkQualModule dflags mod
| modulePackageKey mod == thisPackage dflags = False
| [pkgconfig] <- [modConfPkg m | m <- lookup
......@@ -1458,6 +1480,27 @@ mkPrintUnqualified dflags env = (qual_name, qual_mod)
| otherwise = True
where lookup = eltsUFM $ lookupModuleInAllPackages dflags (moduleName mod)
-- | Creates a function for formatting packages based on two heuristics:
-- (1) don't qualify if the package in question is "main", and (2) only qualify
-- with a package key if the package ID would be ambiguous.
mkQualPackage :: DynFlags -> QueryQualifyPackage
mkQualPackage dflags pkg_key
| pkg_key == mainPackageKey
-- Skip the lookup if it's main, since it won't be in the package
-- database!
= False
| filter ((pkgid ==) . sourcePackageId)
(eltsUFM (pkgIdMap (pkgState dflags))) `lengthIs` 1
-- this says: we are given a package pkg-0.1@MMM, are there only one
-- exposed packages whose package ID is pkg-0.1?
= False
| otherwise
= True
where pkg = fromMaybe (pprPanic "qual_pkg" (ftext (packageKeyFS pkg_key)))
(lookupPackage (pkgIdMap (pkgState dflags)) pkg_key)
pkgid = sourcePackageId pkg
\end{code}
......
......@@ -26,7 +26,8 @@ module PackageConfig (
import Distribution.InstalledPackageInfo
import Distribution.ModuleName
import Distribution.Package
import Distribution.Package hiding (PackageKey, mkPackageKey)
import qualified Distribution.Package as Cabal
import Distribution.Text
import Distribution.Version
......@@ -43,23 +44,23 @@ defaultPackageConfig :: PackageConfig
defaultPackageConfig = emptyInstalledPackageInfo
-- -----------------------------------------------------------------------------
-- PackageKey (package names with versions)
-- PackageKey (package names, versions and dep hash)
-- $package_naming
-- #package_naming#
-- Mostly the compiler deals in terms of 'PackageKey's, which have the
-- form @<pkg>-<version>@. You're expected to pass in the version for
-- the @-package-name@ flag. However, for wired-in packages like @base@
-- & @rts@, we don't necessarily know what the version is, so these are
-- handled specially; see #wired_in_packages#.
-- Mostly the compiler deals in terms of 'PackageKey's, which are md5 hashes
-- of a package ID, keys of its dependencies, and Cabal flags. You're expected
-- to pass in the package key in the @-this-package-key@ flag. However, for
-- wired-in packages like @base@ & @rts@, we don't necessarily know what the
-- version is, so these are handled specially; see #wired_in_packages#.
-- | Turn a Cabal 'PackageIdentifier' into a GHC 'PackageKey'
mkPackageKey :: PackageIdentifier -> PackageKey
mkPackageKey :: Cabal.PackageKey -> PackageKey
mkPackageKey = stringToPackageKey . display
-- | Get the GHC 'PackageKey' right out of a Cabalish 'PackageConfig'
packageConfigId :: PackageConfig -> PackageKey
packageConfigId = mkPackageKey . sourcePackageId
packageConfigId = mkPackageKey . packageKey
-- | Turn a 'PackageConfig', which contains GHC 'Module.ModuleName's into a Cabal specific
-- 'InstalledPackageInfo' which contains Cabal 'Distribution.ModuleName.ModuleName's
......
......@@ -33,6 +33,7 @@ module Packages (
ModuleExport(..),
-- * Utils
packageKeyPackageIdString,
isDllName
)
where
......@@ -53,7 +54,7 @@ import Maybes
import System.Environment ( getEnv )
import Distribution.InstalledPackageInfo
import Distribution.InstalledPackageInfo.Binary
import Distribution.Package hiding (PackageId,depends)
import Distribution.Package hiding (depends, PackageKey, mkPackageKey)
import Distribution.ModuleExport
import FastString
import ErrUtils ( debugTraceMsg, putMsg, MsgDoc )
......@@ -383,6 +384,14 @@ applyPackageFlag dflags unusable pkgs flag =
ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs)
_ -> panic "applyPackageFlag"
ExposePackageKey str ->
case selectPackages (matchingKey str) pkgs unusable of
Left ps -> packageFlagErr dflags flag ps
Right (p:ps,qs) -> return (p':ps')
where p' = p {exposed=True}
ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs)
_ -> panic "applyPackageFlag"
HidePackage str ->
case selectPackages (matchingStr str) pkgs unusable of
Left ps -> packageFlagErr dflags flag ps
......@@ -441,6 +450,9 @@ matchingStr str p
matchingId :: String -> PackageConfig -> Bool
matchingId str p = InstalledPackageId str == installedPackageId p
matchingKey :: String -> PackageConfig -> Bool
matchingKey str p = str == display (packageKey p)
sortByVersion :: [InstalledPackageInfo_ m] -> [InstalledPackageInfo_ m]
sortByVersion = sortBy (flip (comparing (pkgVersion.sourcePackageId)))
......@@ -465,12 +477,14 @@ packageFlagErr dflags flag reasons
where err = text "cannot satisfy " <> ppr_flag <>
(if null reasons then empty else text ": ") $$
nest 4 (ppr_reasons $$
-- ToDo: this admonition seems a bit dodgy
text "(use -v for more information)")
ppr_flag = case flag of
IgnorePackage p -> text "-ignore-package " <> text p
HidePackage p -> text "-hide-package " <> text p
ExposePackage p -> text "-package " <> text p
ExposePackageId p -> text "-package-id " <> text p
ExposePackageKey p -> text "-package-key " <> text p
TrustPackage p -> text "-trust " <> text p
DistrustPackage p -> text "-distrust " <> text p
ppr_reasons = vcat (map ppr_reason reasons)
......@@ -520,15 +534,7 @@ findWiredInPackages dflags pkgs = do
--
let
wired_in_pkgids :: [String]
wired_in_pkgids = map packageKeyString
[ primPackageKey,
integerPackageKey,
basePackageKey,
rtsPackageKey,
thPackageKey,
thisGhcPackageKey,
dphSeqPackageKey,
dphParPackageKey ]
wired_in_pkgids = map packageKeyString wiredInPackageKeys
matches :: PackageConfig -> String -> Bool
pc `matches` pid = display (pkgName (sourcePackageId pc)) == pid
......@@ -588,7 +594,9 @@ findWiredInPackages dflags pkgs = do
updateWiredInDependencies pkgs = map upd_pkg pkgs
where upd_pkg p
| installedPackageId p `elem` wired_in_ids
= p { sourcePackageId = (sourcePackageId p){ pkgVersion = Version [] [] } }
= let pid = (sourcePackageId p) { pkgVersion = Version [] [] }
in p { sourcePackageId = pid
, packageKey = OldPackageKey pid }
| otherwise
= p
......@@ -666,7 +674,7 @@ shadowPackages pkgs preferred
in Map.fromList shadowed
where
check (shadowed,pkgmap) pkg
| Just oldpkg <- lookupUFM pkgmap (packageConfigId pkg)
| Just oldpkg <- lookupUFM pkgmap pkgid
, let
ipid_new = installedPackageId pkg
ipid_old = installedPackageId oldpkg
......@@ -678,7 +686,8 @@ shadowPackages pkgs preferred
| otherwise
= (shadowed, pkgmap')
where
pkgmap' = addToUFM pkgmap (packageConfigId pkg) pkg
pkgid = mkFastString (display (sourcePackageId pkg))
pkgmap' = addToUFM pkgmap pkgid pkg
-- -----------------------------------------------------------------------------
......@@ -730,12 +739,12 @@ mkPackageState dflags pkgs0 preload0 this_package = do
1. P = transitive closure of packages selected by -package-id
2. Apply shadowing. When there are multiple packages with the same
sourcePackageId,
packageKey,
* if one is in P, use that one
* otherwise, use the one highest in the package stack
[
rationale: we cannot use two packages with the same sourcePackageId
in the same program, because sourcePackageId is the symbol prefix.
rationale: we cannot use two packages with the same packageKey
in the same program, because packageKey is the symbol prefix.
Hence we must select a consistent set of packages to use. We have
a default algorithm for doing this: packages higher in the stack
shadow those lower down. This default algorithm can be overriden
......@@ -782,9 +791,15 @@ mkPackageState dflags pkgs0 preload0 this_package = do
-- XXX this is just a variant of nub
ipid_map = Map.fromList [ (installedPackageId p, p) | p <- pkgs0 ]
-- NB: Prefer the last one (i.e. the one highest in the package stack
pk_map = Map.fromList [ (packageConfigId p, p) | p <- pkgs0 ]
ipid_selected = depClosure ipid_map [ InstalledPackageId i
ipid_selected = depClosure ipid_map ([ InstalledPackageId i
| ExposePackageId i <- flags ]
++ [ installedPackageId pkg
| ExposePackageKey k <- flags
, Just pkg <- [Map.lookup
(stringToPackageKey k) pk_map]])
(ignore_flags, other_flags) = partition is_ignore flags
is_ignore IgnorePackage{} = True
......@@ -819,6 +834,7 @@ mkPackageState dflags pkgs0 preload0 this_package = do
= take 1 $ sortByVersion (filter (matchingStr s) pkgs2)
-- -package P means "the latest version of P" (#7030)
get_exposed (ExposePackageId s) = filter (matchingId s) pkgs2
get_exposed (ExposePackageKey s) = filter (matchingKey s) pkgs2
get_exposed _ = []
-- hide packages that are subsumed by later versions
......@@ -1113,6 +1129,13 @@ missingDependencyMsg (Just parent)
-- -----------------------------------------------------------------------------
packageKeyPackageIdString :: DynFlags -> PackageKey -> String
packageKeyPackageIdString dflags pkg_key
| pkg_key == mainPackageKey = "main"
| otherwise = maybe "(unknown)"
(display . sourcePackageId)
(lookupPackage (pkgIdMap (pkgState dflags)) pkg_key)
-- | Will the 'Name' come from a dynamically linked library?
isDllName :: DynFlags -> PackageKey -> Module -> Name -> Bool
-- Despite the "dll", I think this function just means that
......
\begin{code}
module Packages where
-- Well, this is kind of stupid...
import {-# SOURCE #-} Module (PackageKey)
import {-# SOURCE #-} DynFlags (DynFlags)
data PackageState
packageKeyPackageIdString :: DynFlags -> PackageKey -> String
\end{code}
......@@ -53,15 +53,17 @@ module Outputable (
-- * Controlling the style in which output is printed
BindingSite(..),
PprStyle, CodeStyle(..), PrintUnqualified,
PprStyle, CodeStyle(..), PrintUnqualified(..),
QueryQualifyName, QueryQualifyModule, QueryQualifyPackage,
reallyAlwaysQualify, reallyAlwaysQualifyNames,
alwaysQualify, alwaysQualifyNames, alwaysQualifyModules,
neverQualify, neverQualifyNames, neverQualifyModules,
QualifyName(..),
QualifyName(..), queryQual,
sdocWithDynFlags, sdocWithPlatform,
getPprStyle, withPprStyle, withPprStyleDoc,
pprDeeper, pprDeeperList, pprSetDepth,
codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
ifPprDebug, qualName, qualModule,
ifPprDebug, qualName, qualModule, qualPackage,
mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle,
mkUserStyle, cmdlineParserStyle, Depth(..),
......@@ -76,7 +78,7 @@ import {-# SOURCE #-} DynFlags( DynFlags,
targetPlatform, pprUserLength, pprCols,
useUnicode, useUnicodeSyntax,
unsafeGlobalDynFlags )
import {-# SOURCE #-} Module( Module, ModuleName, moduleName )
import {-# SOURCE #-} Module( PackageKey, Module, ModuleName, moduleName )
import {-# SOURCE #-} OccName( OccName )
import {-# SOURCE #-} StaticFlags( opt_PprStyle_Debug, opt_NoDebugOutput )
......@@ -142,12 +144,15 @@ data Depth = AllTheWay
-- -----------------------------------------------------------------------------
-- Printing original names
-- When printing code that contains original names, we need to map the
-- | When printing code that contains original names, we need to map the
-- original names back to something the user understands. This is the
-- purpose of the pair of functions that gets passed around
-- purpose of the triple of functions that gets passed around
-- when rendering 'SDoc'.
type PrintUnqualified = (QueryQualifyName, QueryQualifyModule)
data PrintUnqualified = QueryQualify {
queryQualifyName :: QueryQualifyName,
queryQualifyModule :: QueryQualifyModule,
queryQualifyPackage :: QueryQualifyPackage
}
-- | given an /original/ name, this function tells you which module
-- name it should be qualified with when printing for the user, if
......@@ -161,6 +166,9 @@ type QueryQualifyName = Module -> OccName -> QualifyName
-- a package name to disambiguate it.
type QueryQualifyModule = Module -> Bool
-- | For a given package, we need to know whether to print it with
-- the package key to disambiguate it.
type QueryQualifyPackage = PackageKey -> Bool
-- See Note [Printing original names] in HscTypes
data QualifyName -- given P:M.T
......@@ -173,6 +181,10 @@ data QualifyName -- given P:M.T
-- 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"
reallyAlwaysQualifyNames :: QueryQualifyName
reallyAlwaysQualifyNames _ _ = NameNotInScope2
-- | NB: This won't ever show package IDs
alwaysQualifyNames :: QueryQualifyName
alwaysQualifyNames m _ = NameQual (moduleName m)
......@@ -185,9 +197,23 @@ alwaysQualifyModules _ = True
neverQualifyModules :: QueryQualifyModule
neverQualifyModules _ = False
alwaysQualify, neverQualify :: PrintUnqualified
alwaysQualify = (alwaysQualifyNames, alwaysQualifyModules)
neverQualify = (neverQualifyNames, neverQualifyModules)
alwaysQualifyPackages :: QueryQualifyPackage
alwaysQualifyPackages _ = True
neverQualifyPackages :: QueryQualifyPackage
neverQualifyPackages _ = False
reallyAlwaysQualify, alwaysQualify, neverQualify :: PrintUnqualified
reallyAlwaysQualify
= QueryQualify reallyAlwaysQualifyNames
alwaysQualifyModules
alwaysQualifyPackages
alwaysQualify = QueryQualify alwaysQualifyNames
alwaysQualifyModules
alwaysQualifyPackages
neverQualify = QueryQualify neverQualifyNames
neverQualifyModules
neverQualifyPackages