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 ...@@ -43,6 +43,7 @@ module Module
mainPackageKey, mainPackageKey,
thisGhcPackageKey, thisGhcPackageKey,
interactivePackageKey, isInteractiveModule, interactivePackageKey, isInteractiveModule,
wiredInPackageKeys,
-- * The Module type -- * The Module type
Module, Module,
...@@ -82,6 +83,7 @@ import UniqFM ...@@ -82,6 +83,7 @@ import UniqFM
import FastString import FastString
import Binary import Binary
import Util import Util
import {-# SOURCE #-} Packages
import Data.Data import Data.Data
import Data.Map (Map) import Data.Map (Map)
...@@ -274,7 +276,7 @@ pprPackagePrefix p mod = getPprStyle doc ...@@ -274,7 +276,7 @@ pprPackagePrefix p mod = getPprStyle doc
if p == mainPackageKey if p == mainPackageKey
then empty -- never qualify the main package in code then empty -- never qualify the main package in code
else ztext (zEncodeFS (packageKeyFS p)) <> char '_' 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 -- the PrintUnqualified tells us which modules have to
-- be qualified with package names -- be qualified with package names
| otherwise = empty | otherwise = empty
...@@ -293,7 +295,10 @@ class HasModule m where ...@@ -293,7 +295,10 @@ class HasModule m where
%************************************************************************ %************************************************************************
\begin{code} \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 ) newtype PackageKey = PId FastString deriving( Eq, Typeable )
-- here to avoid module loops with PackageConfig -- here to avoid module loops with PackageConfig
...@@ -316,7 +321,12 @@ stablePackageKeyCmp :: PackageKey -> PackageKey -> Ordering ...@@ -316,7 +321,12 @@ stablePackageKeyCmp :: PackageKey -> PackageKey -> Ordering
stablePackageKeyCmp p1 p2 = packageKeyFS p1 `compare` packageKeyFS p2 stablePackageKeyCmp p1 p2 = packageKeyFS p1 `compare` packageKeyFS p2
instance Outputable PackageKey where 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 instance Binary PackageKey where
put_ bh pid = put_ bh (packageKeyFS pid) put_ bh pid = put_ bh (packageKeyFS pid)
...@@ -377,6 +387,16 @@ mainPackageKey = fsToPackageKey (fsLit "main") ...@@ -377,6 +387,16 @@ mainPackageKey = fsToPackageKey (fsLit "main")
isInteractiveModule :: Module -> Bool isInteractiveModule :: Module -> Bool
isInteractiveModule mod = modulePackageKey mod == interactivePackageKey isInteractiveModule mod = modulePackageKey mod == interactivePackageKey
wiredInPackageKeys :: [PackageKey]
wiredInPackageKeys = [ primPackageKey,
integerPackageKey,
basePackageKey,
rtsPackageKey,
thPackageKey,
thisGhcPackageKey,
dphSeqPackageKey,
dphParPackageKey ]
\end{code} \end{code}
%************************************************************************ %************************************************************************
......
...@@ -105,11 +105,11 @@ Library ...@@ -105,11 +105,11 @@ Library
Include-Dirs: . parser utils Include-Dirs: . parser utils
if impl( ghc >= 7.9 ) 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. -- 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 -- when bootstrapping) because those versions of GHC don't understand
-- that GHC is wired-in. -- that GHC is wired-in.
GHC-Options: -package-name ghc GHC-Options: -this-package-key ghc
if flag(stage1) if flag(stage1)
Include-Dirs: stage1 Include-Dirs: stage1
......
...@@ -437,8 +437,14 @@ ifeq "$(compiler_stage1_VERSION_MUNGED)" "YES" ...@@ -437,8 +437,14 @@ ifeq "$(compiler_stage1_VERSION_MUNGED)" "YES"
compiler_stage1_MUNGED_VERSION = $(subst .$(ProjectPatchLevel),,$(ProjectVersion)) compiler_stage1_MUNGED_VERSION = $(subst .$(ProjectPatchLevel),,$(ProjectVersion))
define compiler_PACKAGE_MAGIC define compiler_PACKAGE_MAGIC
compiler_stage1_VERSION = $(compiler_stage1_MUNGED_VERSION) compiler_stage1_VERSION = $(compiler_stage1_MUNGED_VERSION)
compiler_stage1_PACKAGE_KEY = $(subst .$(ProjectPatchLevel),,$(compiler_stage1_PACKAGE_KEY))
endef 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 # Don't register the non-munged package
compiler_stage1_REGISTER_PACKAGE = NO compiler_stage1_REGISTER_PACKAGE = NO
......
...@@ -70,7 +70,7 @@ import System.Directory hiding (findFile) ...@@ -70,7 +70,7 @@ import System.Directory hiding (findFile)
import System.Directory import System.Directory
#endif #endif
import Distribution.Package hiding (depends) import Distribution.Package hiding (depends, mkPackageKey, PackageKey)
import Exception import Exception
\end{code} \end{code}
......
...@@ -876,6 +876,8 @@ badIfaceFile file err ...@@ -876,6 +876,8 @@ badIfaceFile file err
hiModuleNameMismatchWarn :: Module -> Module -> MsgDoc hiModuleNameMismatchWarn :: Module -> Module -> MsgDoc
hiModuleNameMismatchWarn requested_mod read_mod = hiModuleNameMismatchWarn requested_mod read_mod =
-- ToDo: This will fail to have enough qualification when the package IDs
-- are the same
withPprStyle (mkUserStyle alwaysQualify AllTheWay) $ withPprStyle (mkUserStyle alwaysQualify AllTheWay) $
-- we want the Modules below to be qualified with package names, -- we want the Modules below to be qualified with package names,
-- so reset the PrintUnqualified setting. -- so reset the PrintUnqualified setting.
......
...@@ -406,7 +406,7 @@ strDisplayName_llvm lbl = do ...@@ -406,7 +406,7 @@ strDisplayName_llvm lbl = do
dflags <- getDynFlags dflags <- getDynFlags
let sdoc = pprCLabel platform lbl let sdoc = pprCLabel platform lbl
depth = Outp.PartWay 1 depth = Outp.PartWay 1
style = Outp.mkUserStyle (\ _ _ -> Outp.NameNotInScope2, Outp.alwaysQualifyModules) depth style = Outp.mkUserStyle Outp.reallyAlwaysQualify depth
str = Outp.renderWithStyle dflags sdoc style str = Outp.renderWithStyle dflags sdoc style
return (fsLit (dropInfoSuffix str)) return (fsLit (dropInfoSuffix str))
......
...@@ -90,7 +90,7 @@ module DynFlags ( ...@@ -90,7 +90,7 @@ module DynFlags (
getVerbFlags, getVerbFlags,
updOptLevel, updOptLevel,
setTmpDir, setTmpDir,
setPackageName, setPackageKey,
-- ** Parsing DynFlags -- ** Parsing DynFlags
parseDynamicFlagsCmdLine, parseDynamicFlagsCmdLine,
...@@ -1023,6 +1023,7 @@ isNoLink _ = False ...@@ -1023,6 +1023,7 @@ isNoLink _ = False
data PackageFlag data PackageFlag
= ExposePackage String = ExposePackage String
| ExposePackageId String | ExposePackageId String
| ExposePackageKey String
| HidePackage String | HidePackage String
| IgnorePackage String | IgnorePackage String
| TrustPackage String | TrustPackage String
...@@ -2526,9 +2527,13 @@ package_flags = [ ...@@ -2526,9 +2527,13 @@ package_flags = [
removeUserPkgConf removeUserPkgConf
deprecate "Use -no-user-package-db instead") 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-id" (HasArg exposePackageId)
, Flag "package" (HasArg exposePackage) , Flag "package" (HasArg exposePackage)
, Flag "package-key" (HasArg exposePackageKey)
, Flag "hide-package" (HasArg hidePackage) , Flag "hide-package" (HasArg hidePackage)
, Flag "hide-all-packages" (NoArg (setGeneralFlag Opt_HideAllPackages)) , Flag "hide-all-packages" (NoArg (setGeneralFlag Opt_HideAllPackages))
, Flag "ignore-package" (HasArg ignorePackage) , Flag "ignore-package" (HasArg ignorePackage)
...@@ -3338,11 +3343,13 @@ removeGlobalPkgConf = upd $ \s -> s { extraPkgConfs = filter isNotGlobal . extra ...@@ -3338,11 +3343,13 @@ removeGlobalPkgConf = upd $ \s -> s { extraPkgConfs = filter isNotGlobal . extra
clearPkgConf :: DynP () clearPkgConf :: DynP ()
clearPkgConf = upd $ \s -> s { extraPkgConfs = const [] } clearPkgConf = upd $ \s -> s { extraPkgConfs = const [] }
exposePackage, exposePackageId, hidePackage, ignorePackage, exposePackage, exposePackageId, exposePackageKey, hidePackage, ignorePackage,
trustPackage, distrustPackage :: String -> DynP () trustPackage, distrustPackage :: String -> DynP ()
exposePackage p = upd (exposePackage' p) exposePackage p = upd (exposePackage' p)
exposePackageId p = exposePackageId p =
upd (\s -> s{ packageFlags = ExposePackageId p : packageFlags s }) upd (\s -> s{ packageFlags = ExposePackageId p : packageFlags s })
exposePackageKey p =
upd (\s -> s{ packageFlags = ExposePackageKey p : packageFlags s })
hidePackage p = hidePackage p =
upd (\s -> s{ packageFlags = HidePackage p : packageFlags s }) upd (\s -> s{ packageFlags = HidePackage p : packageFlags s })
ignorePackage p = ignorePackage p =
...@@ -3356,8 +3363,8 @@ exposePackage' :: String -> DynFlags -> DynFlags ...@@ -3356,8 +3363,8 @@ exposePackage' :: String -> DynFlags -> DynFlags
exposePackage' p dflags exposePackage' p dflags
= dflags { packageFlags = ExposePackage p : packageFlags dflags } = dflags { packageFlags = ExposePackage p : packageFlags dflags }
setPackageName :: String -> DynFlags -> DynFlags setPackageKey :: String -> DynFlags -> DynFlags
setPackageName p s = s{ thisPackage = stringToPackageKey p } setPackageKey p s = s{ thisPackage = stringToPackageKey p }
-- If we're linking a binary, then only targets that produce object -- If we're linking a binary, then only targets that produce object
-- code are allowed (requests for other target types are ignored). -- code are allowed (requests for other target types are ignored).
...@@ -3600,6 +3607,7 @@ compilerInfo dflags ...@@ -3600,6 +3607,7 @@ compilerInfo dflags
("Support dynamic-too", if isWindows then "NO" else "YES"), ("Support dynamic-too", if isWindows then "NO" else "YES"),
("Support parallel --make", "YES"), ("Support parallel --make", "YES"),
("Support reexported-modules", "YES"), ("Support reexported-modules", "YES"),
("Uses package keys", "YES"),
("Dynamic by default", if dYNAMIC_BY_DEFAULT dflags ("Dynamic by default", if dYNAMIC_BY_DEFAULT dflags
then "YES" else "NO"), then "YES" else "NO"),
("GHC Dynamic", if dynamicGhc ("GHC Dynamic", if dynamicGhc
......
...@@ -43,7 +43,7 @@ import Maybes ( expectJust ) ...@@ -43,7 +43,7 @@ import Maybes ( expectJust )
import Exception ( evaluate ) import Exception ( evaluate )
import Distribution.Text import Distribution.Text
import Distribution.Package import Distribution.Package hiding (PackageKey, mkPackageKey)
import Data.IORef ( IORef, writeIORef, readIORef, atomicModifyIORef ) import Data.IORef ( IORef, writeIORef, readIORef, atomicModifyIORef )
import System.Directory import System.Directory
import System.FilePath import System.FilePath
......
...@@ -891,6 +891,13 @@ hscGetSafe hsc_env m l = runHsc hsc_env $ do ...@@ -891,6 +891,13 @@ hscGetSafe hsc_env m l = runHsc hsc_env $ do
| otherwise = pkgs | otherwise = pkgs
return (good, 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. -- | 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 -- 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 -- own package be trusted and a list of other packages required to be trusted
...@@ -932,13 +939,13 @@ hscCheckSafe' dflags m l = do ...@@ -932,13 +939,13 @@ hscCheckSafe' dflags m l = do
return (trust == Sf_Trustworthy, pkgRs) return (trust == Sf_Trustworthy, pkgRs)
where where
pkgTrustErr = unitBag $ mkPlainErrMsg dflags l $ pkgTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $
sep [ ppr (moduleName m) sep [ ppr (moduleName m)
<> text ": Can't be safely imported!" <> text ": Can't be safely imported!"
, text "The package (" <> ppr (modulePackageKey m) , text "The package (" <> ppr (modulePackageKey m)
<> text ") the module resides in isn't trusted." <> text ") the module resides in isn't trusted."
] ]
modTrustErr = unitBag $ mkPlainErrMsg dflags l $ modTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $
sep [ ppr (moduleName m) sep [ ppr (moduleName m)
<> text ": Can't be safely imported!" <> text ": Can't be safely imported!"
, text "The module itself isn't safe." ] , text "The module itself isn't safe." ]
...@@ -995,7 +1002,7 @@ checkPkgTrust dflags pkgs = ...@@ -995,7 +1002,7 @@ checkPkgTrust dflags pkgs =
| trusted $ getPackageDetails (pkgState dflags) pkg | trusted $ getPackageDetails (pkgState dflags) pkg
= Nothing = Nothing
| otherwise | otherwise
= Just $ mkPlainErrMsg dflags noSrcSpan = Just $ mkErrMsg dflags noSrcSpan (pkgQual dflags)
$ text "The package (" <> ppr pkg <> text ") is required" <> $ text "The package (" <> ppr pkg <> text ") is required" <>
text " to be trusted but it isn't!" text " to be trusted but it isn't!"
......
...@@ -54,6 +54,7 @@ module HscTypes ( ...@@ -54,6 +54,7 @@ module HscTypes (
setInteractivePrintName, icInteractiveModule, setInteractivePrintName, icInteractiveModule,
InteractiveImport(..), setInteractivePackage, InteractiveImport(..), setInteractivePackage,
mkPrintUnqualified, pprModulePrefix, mkPrintUnqualified, pprModulePrefix,
mkQualPackage, mkQualModule,
-- * Interfaces -- * Interfaces
ModIface(..), mkIfaceWarnCache, mkIfaceHashCache, mkIfaceFixCache, ModIface(..), mkIfaceWarnCache, mkIfaceHashCache, mkIfaceFixCache,
...@@ -443,7 +444,7 @@ instance Outputable TargetId where ...@@ -443,7 +444,7 @@ instance Outputable TargetId where
-- | Helps us find information about modules in the home package -- | Helps us find information about modules in the home package
type HomePackageTable = ModuleNameEnv HomeModInfo type HomePackageTable = ModuleNameEnv HomeModInfo
-- Domain = modules in the home package that have been fully compiled -- 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 -- | Helps us find information about modules in the imported packages
type PackageIfaceTable = ModuleEnv ModIface type PackageIfaceTable = ModuleEnv ModIface
...@@ -1138,7 +1139,7 @@ The details are a bit tricky though: ...@@ -1138,7 +1139,7 @@ The details are a bit tricky though:
extend the HPT. extend the HPT.
* The 'thisPackage' field of DynFlags is *not* set to 'interactive'. * 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. package to which :load'ed modules are added to.
* So how do we arrange that declarations at the command prompt get * So how do we arrange that declarations at the command prompt get
...@@ -1148,7 +1149,7 @@ The details are a bit tricky though: ...@@ -1148,7 +1149,7 @@ The details are a bit tricky though:
turn get the module from it 'icInteractiveModule' field of the turn get the module from it 'icInteractiveModule' field of the
interactive context. 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 * The main trickiness is that the type environment (tcg_type_env and
fixity envt (tcg_fix_env), and instances (tcg_insts, tcg_fam_insts) 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. ...@@ -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 This is handled by the qual_mod component of PrintUnqualified, inside
the (ppr mod) of case (3), in Name.pprModulePrefix 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} \begin{code}
-- | Creates some functions that work out the best ways to format -- | 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 :: DynFlags -> GlobalRdrEnv -> PrintUnqualified
mkPrintUnqualified dflags env = (qual_name, qual_mod) mkPrintUnqualified dflags env = QueryQualify qual_name
(mkQualModule dflags)
(mkQualPackage dflags)
where where
qual_name mod occ qual_name mod occ
| [gre] <- unqual_gres | [gre] <- unqual_gres
...@@ -1446,7 +1464,11 @@ mkPrintUnqualified dflags env = (qual_name, qual_mod) ...@@ -1446,7 +1464,11 @@ mkPrintUnqualified dflags env = (qual_name, qual_mod)
-- "import M" would resolve unambiguously to P:M. (if P is the -- "import M" would resolve unambiguously to P:M. (if P is the
-- current package we can just assume it is unqualified). -- 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 | modulePackageKey mod == thisPackage dflags = False
| [pkgconfig] <- [modConfPkg m | m <- lookup | [pkgconfig] <- [modConfPkg m | m <- lookup
...@@ -1458,6 +1480,27 @@ mkPrintUnqualified dflags env = (qual_name, qual_mod) ...@@ -1458,6 +1480,27 @@ mkPrintUnqualified dflags env = (qual_name, qual_mod)
| otherwise = True | otherwise = True
where lookup = eltsUFM $ lookupModuleInAllPackages dflags (moduleName mod) 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} \end{code}
......
...@@ -26,7 +26,8 @@ module PackageConfig ( ...@@ -26,7 +26,8 @@ module PackageConfig (
import Distribution.InstalledPackageInfo import Distribution.InstalledPackageInfo
import Distribution.ModuleName import Distribution.ModuleName
import Distribution.Package import Distribution.Package hiding (PackageKey, mkPackageKey)
import qualified Distribution.Package as Cabal
import Distribution.Text import Distribution.Text
import Distribution.Version import Distribution.Version
...@@ -43,23 +44,23 @@ defaultPackageConfig :: PackageConfig ...@@ -43,23 +44,23 @@ defaultPackageConfig :: PackageConfig
defaultPackageConfig = emptyInstalledPackageInfo defaultPackageConfig = emptyInstalledPackageInfo
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- PackageKey (package names with versions) -- PackageKey (package names, versions and dep hash)
-- $package_naming -- $package_naming
-- #package_naming# -- #package_naming#
-- Mostly the compiler deals in terms of 'PackageKey's, which have the -- Mostly the compiler deals in terms of 'PackageKey's, which are md5 hashes
-- form @<pkg>-<version>@. You're expected to pass in the version for -- of a package ID, keys of its dependencies, and Cabal flags. You're expected
-- the @-package-name@ flag. However, for wired-in packages like @base@ -- to pass in the package key in the @-this-package-key@ flag. However, for
-- & @rts@, we don't necessarily know what the version is, so these are -- wired-in packages like @base@ & @rts@, we don't necessarily know what the
-- handled specially; see #wired_in_packages#. -- version is, so these are handled specially; see #wired_in_packages#.
-- | Turn a Cabal 'PackageIdentifier' into a GHC 'PackageKey' -- | Turn a Cabal 'PackageIdentifier' into a GHC 'PackageKey'
mkPackageKey :: PackageIdentifier -> PackageKey mkPackageKey :: Cabal.PackageKey -> PackageKey
mkPackageKey = stringToPackageKey . display mkPackageKey = stringToPackageKey . display
-- | Get the GHC 'PackageKey' right out of a Cabalish 'PackageConfig' -- | Get the GHC 'PackageKey' right out of a Cabalish 'PackageConfig'
packageConfigId :: PackageConfig -> PackageKey packageConfigId :: PackageConfig -> PackageKey
packageConfigId = mkPackageKey . sourcePackageId packageConfigId = mkPackageKey . packageKey
-- | Turn a 'PackageConfig', which contains GHC 'Module.ModuleName's into a Cabal specific -- | Turn a 'PackageConfig', which contains GHC 'Module.ModuleName's into a Cabal specific
-- 'InstalledPackageInfo' which contains Cabal 'Distribution.ModuleName.ModuleName's -- 'InstalledPackageInfo' which contains Cabal 'Distribution.ModuleName.ModuleName's
......
...@@ -33,6 +33,7 @@ module Packages ( ...@@ -33,6 +33,7 @@ module Packages (
ModuleExport(..), ModuleExport(..),
-- * Utils -- * Utils
packageKeyPackageIdString,
isDllName isDllName
) )
where where
...@@ -53,7 +54,7 @@ import Maybes ...@@ -53,7 +54,7 @@ import Maybes
import System.Environment ( getEnv ) import System.Environment ( getEnv )
import Distribution.InstalledPackageInfo import Distribution.InstalledPackageInfo
import Distribution.InstalledPackageInfo.Binary import Distribution.InstalledPackageInfo.Binary
import Distribution.Package hiding (PackageId,depends) import Distribution.Package hiding (depends, PackageKey, mkPackageKey)
import Distribution.ModuleExport import Distribution.ModuleExport
import FastString import FastString
import ErrUtils ( debugTraceMsg, putMsg, MsgDoc ) import ErrUtils ( debugTraceMsg, putMsg, MsgDoc )
...@@ -383,6 +384,14 @@ applyPackageFlag dflags unusable pkgs flag = ...@@ -383,6 +384,14 @@ applyPackageFlag dflags unusable pkgs flag =
ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs) ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs)
_ -> panic "applyPackageFlag" _ -> 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 -> HidePackage str ->
case selectPackages (matchingStr str) pkgs unusable of case selectPackages (matchingStr str) pkgs unusable of
Left ps -> packageFlagErr dflags flag ps Left ps -> packageFlagErr dflags flag ps
...@@ -441,6 +450,9 @@ matchingStr str p ...@@ -441,6 +450,9 @@ matchingStr str p
matchingId :: String -> PackageConfig -> Bool matchingId :: String -> PackageConfig -> Bool
matchingId str p = InstalledPackageId str == installedPackageId p matchingId str p = InstalledPackageId str == installedPackageId p
matchingKey :: String -> PackageConfig -> Bool
matchingKey str p = str == display (packageKey p)
sortByVersion :: [InstalledPackageInfo_ m] -> [InstalledPackageInfo_ m] sortByVersion :: [InstalledPackageInfo_ m] -> [InstalledPackageInfo_ m]
sortByVersion = sortBy (flip (comparing (pkgVersion.sourcePackageId))) sortByVersion = sortBy (flip (comparing (pkgVersion.sourcePackageId)))
...@@ -465,12 +477,14 @@ packageFlagErr dflags flag reasons ...@@ -465,12 +477,14 @@ packageFlagErr dflags flag reasons
where err = text "cannot satisfy " <> ppr_flag <> where err = text "cannot satisfy " <> ppr_flag <>
(if null reasons then empty else text ": ") $$ (if null reasons then empty else text ": ") $$
nest 4 (ppr_reasons $$ nest 4 (ppr_reasons $$
-- ToDo: this admonition seems a bit dodgy
text "(use -v for more information)") text "(use -v for more information)")
ppr_flag = case flag of ppr_flag = case flag of
IgnorePackage p -> text "-ignore-package " <> text p IgnorePackage p -> text "-ignore-package " <> text p
HidePackage p -> text "-hide-package " <> text p HidePackage p -> text "-hide-package " <> text p
ExposePackage p -> text "-package " <> text p ExposePackage p -> text "-package " <> text p
ExposePackageId p -> text "-package-id " <> text p ExposePackageId p -> text "-package-id " <> text p
ExposePackageKey p -> text "-package-key " <> text p
TrustPackage p -> text "-trust " <> text p TrustPackage p -> text "-trust " <> text p