Commit 998739df authored by Edward Z. Yang's avatar Edward Z. Yang
Browse files

Refactor package flags into several distinct types.



Summary:
Previously, all package flags (-package, -trust-package,
-ignore-package) were bundled up into a single packageFlags
field in DynFlags, under a single type.  This commit separates
them based on what they do.

This is a nice improvement, because it means that Packages can
then be refactored so that a number of functions are "tighter":

    - We know longer have to partition PackageFlags into
      the ignore flag and other flags; ignore flags are just
      put into their own field.

    - Trust flags modify the package database, but exposed
      flags do not (they modify the visibility map); now
      applyPackageFlag and applyTrustFlag have tighter signatures
      which reflect this.

This patch was motivated by the need to have a separate visibility
map for plugin packages, which will be in a companion patch.
Signed-off-by: default avatarEdward Z. Yang <ezyang@cs.stanford.edu>

Test Plan: validate

Reviewers: austin, bgamari, duncan

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1659
parent 21b25dff
......@@ -45,6 +45,7 @@ module DynFlags (
GhcMode(..), isOneShot,
GhcLink(..), isNoLink,
PackageFlag(..), PackageArg(..), ModRenaming(..),
IgnorePackageFlag(..), TrustFlag(..),
PkgConfRef(..),
Option(..), showOpt,
DynLibLoader(..),
......@@ -691,8 +692,12 @@ data DynFlags = DynFlags {
-- ^ The @-package-db@ flags given on the command line, in the order
-- they appeared.
ignorePackageFlags :: [IgnorePackageFlag],
-- ^ The @-ignore-package@ flags from the command line
packageFlags :: [PackageFlag],
-- ^ The @-package@ and @-hide-package@ flags from the command-line
trustFlags :: [TrustFlag],
-- ^ The @-trust@ and @-distrust@ flags
packageEnv :: Maybe FilePath,
-- ^ Filepath to the package environment file (if overriding default)
......@@ -1088,13 +1093,16 @@ data ModRenaming = ModRenaming {
} deriving (Eq)
-- | Flags for manipulating packages.
newtype IgnorePackageFlag = IgnorePackage String -- ^ @-ignore-package@
data TrustFlag
= TrustPackage String -- ^ @-trust@
| DistrustPackage String -- ^ @-distrust@
data PackageFlag
= ExposePackage PackageArg ModRenaming -- ^ @-package@, @-package-id@
-- and @-package-key@
| HidePackage String -- ^ @-hide-package@
| IgnorePackage String -- ^ @-ignore-package@
| TrustPackage String -- ^ @-trust-package@
| DistrustPackage String -- ^ @-distrust-package@
deriving (Eq)
defaultHscTarget :: Platform -> HscTarget
......@@ -1424,6 +1432,8 @@ defaultDynFlags mySettings =
extraPkgConfs = id,
packageFlags = [],
ignorePackageFlags = [],
trustFlags = [],
packageEnv = Nothing,
pkgDatabase = Nothing,
-- This gets filled in with GHC.setSessionDynFlags
......@@ -3778,11 +3788,12 @@ exposeUnitId p =
hidePackage p =
upd (\s -> s{ packageFlags = HidePackage p : packageFlags s })
ignorePackage p =
upd (\s -> s{ packageFlags = IgnorePackage p : packageFlags s })
upd (\s -> s{ ignorePackageFlags = IgnorePackage p : ignorePackageFlags s })
trustPackage p = exposePackage p >> -- both trust and distrust also expose a package
upd (\s -> s{ packageFlags = TrustPackage p : packageFlags s })
upd (\s -> s{ trustFlags = TrustPackage p : trustFlags s })
distrustPackage p = exposePackage p >>
upd (\s -> s{ packageFlags = DistrustPackage p : packageFlags s })
upd (\s -> s{ trustFlags = DistrustPackage p : trustFlags s })
exposePackage' :: String -> DynFlags -> DynFlags
exposePackage' p dflags
......
......@@ -503,27 +503,45 @@ mungePackagePaths top_dir pkgroot pkg =
-- -----------------------------------------------------------------------------
-- Modify our copy of the package database based on a package flag
-- (-package, -hide-package, -ignore-package).
-- Modify our copy of the package database based on trust flags,
-- -trust and -distrust.
applyTrustFlag
:: DynFlags
-> UnusablePackages
-> [PackageConfig]
-> TrustFlag
-> IO [PackageConfig]
applyTrustFlag dflags unusable pkgs flag =
case flag of
-- we trust all matching packages. Maybe should only trust first one?
-- and leave others the same or set them untrusted
TrustPackage str ->
case selectPackages (matchingStr str) pkgs unusable of
Left ps -> trustFlagErr dflags flag ps
Right (ps,qs) -> return (map trust ps ++ qs)
where trust p = p {trusted=True}
DistrustPackage str ->
case selectPackages (matchingStr str) pkgs unusable of
Left ps -> trustFlagErr dflags flag ps
Right (ps,qs) -> return (map distrust ps ++ qs)
where distrust p = p {trusted=False}
applyPackageFlag
:: DynFlags
-> UnusablePackages
-> ([PackageConfig], VisibilityMap) -- Initial database
-> [PackageConfig]
-> VisibilityMap -- Initially exposed
-> PackageFlag -- flag to apply
-> IO ([PackageConfig], VisibilityMap) -- new database
-- ToDo: Unfortunately, we still have to plumb the package config through,
-- because Safe Haskell trust is still implemented by modifying the database.
-- Eventually, track that separately and then axe @[PackageConfig]@ from
-- this fold entirely
-> IO VisibilityMap -- Now exposed
applyPackageFlag dflags unusable (pkgs, vm) flag =
applyPackageFlag dflags unusable pkgs vm flag =
case flag of
ExposePackage arg (ModRenaming b rns) ->
case selectPackages (matching arg) pkgs unusable of
Left ps -> packageFlagErr dflags flag ps
Right (p:_,_) -> return (pkgs, vm')
Right (p:_,_) -> return vm'
where
n = fsPackageName p
vm' = addToUFM_C edit vm_cleared (packageConfigId p) (b, rns, n)
......@@ -540,25 +558,9 @@ applyPackageFlag dflags unusable (pkgs, vm) flag =
HidePackage str ->
case selectPackages (matchingStr str) pkgs unusable of
Left ps -> packageFlagErr dflags flag ps
Right (ps,_) -> return (pkgs, vm')
Right (ps,_) -> return vm'
where vm' = delListFromUFM vm (map packageConfigId ps)
-- we trust all matching packages. Maybe should only trust first one?
-- and leave others the same or set them untrusted
TrustPackage str ->
case selectPackages (matchingStr str) pkgs unusable of
Left ps -> packageFlagErr dflags flag ps
Right (ps,qs) -> return (map trust ps ++ qs, vm)
where trust p = p {trusted=True}
DistrustPackage str ->
case selectPackages (matchingStr str) pkgs unusable of
Left ps -> packageFlagErr dflags flag ps
Right (ps,qs) -> return (map distrust ps ++ qs, vm)
where distrust p = p {trusted=False}
IgnorePackage _ -> panic "applyPackageFlag: IgnorePackage"
selectPackages :: (PackageConfig -> Bool) -> [PackageConfig]
-> UnusablePackages
-> Either [(PackageConfig, UnusablePackageReason)]
......@@ -606,10 +608,23 @@ packageFlagErr dflags (ExposePackage (PackageArg pkg) _) []
where dph_err = text "the " <> text pkg <> text " package is not installed."
$$ text "To install it: \"cabal install dph\"."
is_dph_package pkg = "dph" `isPrefixOf` pkg
packageFlagErr dflags flag reasons
= packageFlagErr' dflags (pprFlag flag) reasons
trustFlagErr :: DynFlags
-> TrustFlag
-> [(PackageConfig, UnusablePackageReason)]
-> IO a
trustFlagErr dflags flag reasons
= packageFlagErr' dflags (pprTrustFlag flag) reasons
packageFlagErr' :: DynFlags
-> SDoc
-> [(PackageConfig, UnusablePackageReason)]
-> IO a
packageFlagErr' dflags flag_doc reasons
= throwGhcExceptionIO (CmdLineError (showSDoc dflags $ err))
where err = text "cannot satisfy " <> pprFlag flag <>
where err = text "cannot satisfy " <> flag_doc <>
(if null reasons then Outputable.empty else text ": ") $$
nest 4 (ppr_reasons $$
text "(use -v for more information)")
......@@ -619,11 +634,8 @@ packageFlagErr dflags flag reasons
pprFlag :: PackageFlag -> SDoc
pprFlag flag = case flag of
IgnorePackage p -> text "-ignore-package " <> text p
HidePackage p -> text "-hide-package " <> text p
ExposePackage a rns -> ppr_arg a <> ppr_rns rns
TrustPackage p -> text "-trust " <> text p
DistrustPackage p -> text "-distrust " <> text p
where ppr_arg arg = case arg of
PackageArg p -> text "-package " <> text p
PackageIdArg p -> text "-package-id " <> text p
......@@ -635,6 +647,11 @@ pprFlag flag = case flag of
ppr_rn (orig, new) | orig == new = ppr orig
| otherwise = ppr orig <+> text "as" <+> ppr new
pprTrustFlag :: TrustFlag -> SDoc
pprTrustFlag flag = case flag of
TrustPackage p -> text "-trust " <> text p
DistrustPackage p -> text "-distrust " <> text p
-- -----------------------------------------------------------------------------
-- Wired-in packages
......@@ -647,7 +664,9 @@ findWiredInPackages
:: DynFlags
-> [PackageConfig] -- database
-> VisibilityMap -- info on what packages are visible
-> IO ([PackageConfig], VisibilityMap, WiredPackagesMap)
-- for wired in selection
-> IO ([PackageConfig], -- package database updated for wired in
WiredPackagesMap) -- map from unit id to wired identity
findWiredInPackages dflags pkgs vis_map = do
--
......@@ -746,14 +765,15 @@ findWiredInPackages dflags pkgs vis_map = do
| Just key' <- Map.lookup key wiredInMap = key'
| otherwise = key
updateVisibilityMap vis_map = foldl' f vis_map wired_in_pkgs
where f vm p = case lookupUFM vis_map (packageConfigId p) of
Nothing -> vm
Just r -> addToUFM vm (stringToUnitId
(packageNameString p)) r
return (updateWiredInDependencies pkgs, wiredInMap)
updateVisibilityMap :: WiredPackagesMap -> VisibilityMap -> VisibilityMap
updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (Map.toList wiredInMap)
where f vm (from, to) = case lookupUFM vis_map from of
Nothing -> vm
Just r -> addToUFM vm to r
return (updateWiredInDependencies pkgs, updateVisibilityMap vis_map, wiredInMap)
-- ----------------------------------------------------------------------------
......@@ -820,7 +840,7 @@ findBroken is_shadowed pkgs pkg_map0 = go [] pkg_map0 pkgs
-- -----------------------------------------------------------------------------
-- Ignore packages
ignorePackages :: [PackageFlag] -> [PackageConfig] -> UnusablePackages
ignorePackages :: [IgnorePackageFlag] -> [PackageConfig] -> UnusablePackages
ignorePackages flags pkgs = Map.fromList (concatMap doit flags)
where
doit (IgnorePackage str) =
......@@ -830,7 +850,6 @@ ignorePackages flags pkgs = Map.fromList (concatMap doit flags)
-- missing package is not an error for -ignore-package,
-- because a common usage is to -ignore-package P as
-- a preventative measure just in case P exists.
doit _ = panic "ignorePackages"
-- -----------------------------------------------------------------------------
-- When all the command-line options are in, we can process our package
......@@ -854,41 +873,57 @@ mkPackageState dflags0 dbs preload0 = do
{-
Plan.
The goal is to build a single, unified package database based
on all of the input databases, which upholds the invariant that
there is only one package per any UnitId, and that there are no
dangling dependencies. We'll do this by successively merging
each input database into this unified database:
There are two main steps for making the package state:
1. We want to build a single, unified package database based
on all of the input databases, which upholds the invariant that
there is only one package per any UnitId, and that there are no
dangling dependencies. We'll do this by successively merging each
input database into this unified database:
a) if an input database defines unit ID that is already in
the unified database, that package SHADOWS the existing
package in the current unified database
* for every such shadowed package, we remove it and any
packages which transitively depend on it from the
unified datbase
1. if an input database defines unit ID that is already in
the unified database, that package SHADOWS the existing
package in the unit database
* for every such shadowed package, we remove it and any
packages which transitively depend on it from the
unified datbase
b) remove packages selected by -ignore-package from input database
2. remove packages selected by -ignore-package from input database
c) remove any packages with missing dependencies or mutually recursive
dependencies from the input database
3. remove any packages with missing dependencies or mutually recursive
dependencies from the input database
d) report (with -v) any packages that were removed by steps 1-3
4. report (with -v) any packages that were removed by steps 1-3
e) merge the input database into the unified database
5. merge the input database into the unified database
2. We want to look at the flags controlling package visibility,
and build a mapping of what module names are in scope and
where they live.
Once this is all done, on the final unified database we:
a) on the final, unified database, we apply -trust/-distrust
flags directly, modifying the database so that the 'trusted'
field has the correct value.
1. apply flags to set exposed/hidden on the resulting packages
- if any flag refers to a package which was removed by 1-5, then
we can give an error message explaining why
b) we use the -package/-hide-package flags to compute a
visibility map, stating what packages are "exposed" for
the purposes of computing the module map.
* if any flag refers to a package which was removed by 1-5, then
we can give an error message explaining why
* if -hide-all-packages what not specified, this step also
hides packages which are superseded by later exposed packages
* this step is done TWICE if -plugin-package/-hide-all-plugin-packages
are used
2. hide any packages which are superseded by later exposed packages
c) based on the visibility map, we pick wired packages and rewrite
them to have the expected unitId.
d) finally, using the visibility map and the package database,
we build a mapping saying what every in scope module name points to.
-}
let flags = reverse (packageFlags dflags)
(ignore_flags, other_flags) = partition is_ignore flags
is_ignore IgnorePackage{} = True
is_ignore _ = False
let other_flags = reverse (packageFlags dflags)
ignore_flags = reverse (ignorePackageFlags dflags)
let merge (pkg_map, prev_unusable) (db_path, db) = do
debugTraceMsg dflags 2 $
......@@ -951,7 +986,10 @@ mkPackageState dflags0 dbs preload0 = do
pkg_map' = mk_pkg_map (shadowed_pkgs ++ db3)
(pkg_map1, unusable) <- foldM merge (Map.empty, Map.empty) dbs
let pkgs1 = Map.elems pkg_map1
-- Apply trust flags (these flags apply regardless of whether
-- or not packages are visible or not)
pkgs1 <- foldM (applyTrustFlag dflags unusable)
(Map.elems pkg_map1) (reverse (trustFlags dflags))
--
-- Calculate the initial set of packages, prior to any package flags.
......@@ -974,21 +1012,22 @@ mkPackageState dflags0 dbs preload0 = do
emptyUFM initial
--
-- Modify the package database according to the command-line flags
-- (-package, -hide-package, -ignore-package, -hide-all-packages).
-- This needs to know about the unusable packages, since if a user tries
-- to enable an unusable package, we should let them know.
-- Compute a visibility map according to the command-line flags (-package,
-- -hide-package). This needs to know about the unusable packages, since if a
-- user tries to enable an unusable package, we should let them know.
--
(pkgs2, vis_map2) <- foldM (applyPackageFlag dflags unusable)
(pkgs1, vis_map1) other_flags
vis_map2 <- foldM (applyPackageFlag dflags unusable pkgs1)
vis_map1 other_flags
--
-- Sort out which packages are wired in. This has to be done last, since
-- it modifies the unit ids of wired in packages, but when we process
-- package arguments we need to key against the old versions. We also
-- have to update the visibility map in the process.
-- package arguments we need to key against the old versions.
--
(pkgs3, vis_map, wired_map) <- findWiredInPackages dflags pkgs2 vis_map2
(pkgs2, wired_map) <- findWiredInPackages dflags pkgs1 vis_map2
-- Update the visibility map, so we treat wired packages as visible.
let vis_map = updateVisibilityMap wired_map vis_map2
--
-- Here we build up a set of the packages mentioned in -package
......@@ -999,14 +1038,14 @@ mkPackageState dflags0 dbs preload0 = do
--
let preload1 = [ let key = unitId p
in fromMaybe key (Map.lookup key wired_map)
| f <- flags, p <- get_exposed f ]
| f <- other_flags, p <- get_exposed f ]
get_exposed (ExposePackage a _) = take 1 . sortByVersion
. filter (matching a)
$ pkgs2
$ pkgs1
get_exposed _ = []
let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs3
let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs2
let preload2 = preload1
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment