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: Edward 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

14 files changed, 211 insertions, 62 deletions

diff --git a/compiler/basicTypes/Module.lhs b/compiler/basicTypes/Module.lhs
index 3ec9f6a9b0..8f21d66bc1 100644
--- a/compiler/basicTypes/Module.lhs
+++ b/compiler/basicTypes/Module.lhs
@@ -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}
 
 %************************************************************************
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 838a908364..d449adac67 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -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
diff --git a/compiler/ghc.mk b/compiler/ghc.mk
index c236bcf7ff..d23d1fe5b6 100644
--- a/compiler/ghc.mk
+++ b/compiler/ghc.mk
@@ -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
 
diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs
index 74dec19d14..013918c13f 100644
--- a/compiler/ghci/Linker.lhs
+++ b/compiler/ghci/Linker.lhs
@@ -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}
diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs
index 04b0476f30..2be6e9d4d8 100644
--- a/compiler/iface/LoadIface.lhs
+++ b/compiler/iface/LoadIface.lhs
@@ -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.
diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs
index 686b352c2a..50cd824b24 100644
--- a/compiler/llvmGen/LlvmCodeGen/Base.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Base.hs
@@ -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))
 
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index dfd2e27457..8280730747 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -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
diff --git a/compiler/main/Finder.lhs b/compiler/main/Finder.lhs
index 37395ce956..ded85140fd 100644
--- a/compiler/main/Finder.lhs
+++ b/compiler/main/Finder.lhs
@@ -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
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index f02abe84dd..8710297fd4 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -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!"
 
diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index c0794def95..e0d11e4ef2 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -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}
 
 
diff --git a/compiler/main/PackageConfig.hs b/compiler/main/PackageConfig.hs
index 520b533380..864980be9d 100644
--- a/compiler/main/PackageConfig.hs
+++ b/compiler/main/PackageConfig.hs
@@ -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
diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs
index 5973bc5d4b..93b566fb0e 100644
--- a/compiler/main/Packages.lhs
+++ b/compiler/main/Packages.lhs
@@ -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
-                                          | ExposePackageId i <- flags ]
+      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
diff --git a/compiler/main/Packages.lhs-boot b/compiler/main/Packages.lhs-boot
index 3a1712e2da..3fd0fd5422 100644
--- a/compiler/main/Packages.lhs-boot
+++ b/compiler/main/Packages.lhs-boot
@@ -1,4 +1,8 @@
 \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}
diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index e32261de65..a65607a7c3 100644
--- a/compiler/utils/Outputable.lhs
+++ b/compiler/utils/Outputable.lhs
@@ -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
 
 defaultUserStyle, defaultDumpStyle :: PprStyle
 
@@ -297,13 +323,22 @@ sdocWithPlatform f = sdocWithDynFlags (f . targetPlatform)
 
 \begin{code}
 qualName :: PprStyle -> QueryQualifyName
-qualName (PprUser (qual_name,_) _)  mod occ = qual_name mod occ
+qualName (PprUser q _)  mod occ = queryQualifyName q mod occ
 qualName _other                     mod _   = NameQual (moduleName mod)
 
 qualModule :: PprStyle -> QueryQualifyModule
-qualModule (PprUser (_,qual_mod) _)  m = qual_mod m
+qualModule (PprUser q _)  m = queryQualifyModule q m
 qualModule _other                   _m = True
 
+qualPackage :: PprStyle -> QueryQualifyPackage
+qualPackage (PprUser q _)  m = queryQualifyPackage q m
+qualPackage _other                   _m = True
+
+queryQual :: PprStyle -> PrintUnqualified
+queryQual s = QueryQualify (qualName s)
+                           (qualModule s)
+                           (qualPackage s)
+
 codeStyle :: PprStyle -> Bool
 codeStyle (PprCode _)     = True
 codeStyle _               = False