diff options
Diffstat (limited to 'compiler/main')
| -rw-r--r-- | compiler/main/DynFlags.hs | 18 | ||||
| -rw-r--r-- | compiler/main/Finder.lhs | 2 | ||||
| -rw-r--r-- | compiler/main/HscMain.hs | 13 | ||||
| -rw-r--r-- | compiler/main/HscTypes.lhs | 55 | ||||
| -rw-r--r-- | compiler/main/PackageConfig.hs | 19 | ||||
| -rw-r--r-- | compiler/main/Packages.lhs | 59 | ||||
| -rw-r--r-- | compiler/main/Packages.lhs-boot | 4 |
7 files changed, 128 insertions, 42 deletions
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} |