[commit: ghc] master: ghc-pkg register/update --enable-multi-instance (dd3a724)
git at git.haskell.org
git at git.haskell.org
Wed Jul 2 15:12:14 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/dd3a7245d4d557b9e19bfa53b0fb2733c6fd4f88/ghc
>---------------------------------------------------------------
commit dd3a7245d4d557b9e19bfa53b0fb2733c6fd4f88
Author: Austin Seipp <austin at well-typed.com>
Date: Wed Jul 2 08:54:22 2014 -0500
ghc-pkg register/update --enable-multi-instance
Summary:
New flag to ghc-pkg register/update to lift the restriction on multiple instances of the same package version being in a db at once.
Lifting the restriction is easy. The tricky bit is checking ghc does something sensible, but from the reading of the code it should treat such instances the same way it does with multiple instances between multiple DBs.
We'll also need a way to unregister by installed package id.
Test Plan: need to test that ghc is doing what we expect, at least if you use it like -hide-all-packages -package-id this -package-id that
Reviewers: ezyang, simonmar
Reviewed By: simonmar
Subscribers: relrod
Projects: #ghc
Differential Revision: https://phabricator.haskell.org/D32
>---------------------------------------------------------------
dd3a7245d4d557b9e19bfa53b0fb2733c6fd4f88
utils/ghc-pkg/Main.hs | 49 ++++++++++++++++++++++++++++++++++++-------------
1 file changed, 36 insertions(+), 13 deletions(-)
diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index 290fb82..e51755c 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -114,6 +114,7 @@ data Flag
| FlagForce
| FlagForceFiles
| FlagAutoGHCiLibs
+ | FlagMultiInstance
| FlagExpandEnvVars
| FlagExpandPkgroot
| FlagNoExpandPkgroot
@@ -146,6 +147,8 @@ flags = [
"ignore missing directories and libraries only",
Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
"automatically build libs for GHCi (with register)",
+ Option [] ["enable-multi-instance"] (NoArg FlagMultiInstance)
+ "allow registering multiple instances of the same package version",
Option [] ["expand-env-vars"] (NoArg FlagExpandEnvVars)
"expand environment variables (${name}-style) in input package descriptions",
Option [] ["expand-pkgroot"] (NoArg FlagExpandPkgroot)
@@ -309,6 +312,7 @@ runit verbosity cli nonopts = do
| FlagForceFiles `elem` cli = ForceFiles
| otherwise = NoForce
auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
+ multi_instance = FlagMultiInstance `elem` cli
expand_env_vars= FlagExpandEnvVars `elem` cli
mexpand_pkgroot= foldl' accumExpandPkgroot Nothing cli
where accumExpandPkgroot _ FlagExpandPkgroot = Just True
@@ -355,10 +359,12 @@ runit verbosity cli nonopts = do
initPackageDB filename verbosity cli
["register", filename] ->
registerPackage filename verbosity cli
- auto_ghci_libs expand_env_vars False force
+ auto_ghci_libs multi_instance
+ expand_env_vars False force
["update", filename] ->
registerPackage filename verbosity cli
- auto_ghci_libs expand_env_vars True force
+ auto_ghci_libs multi_instance
+ expand_env_vars True force
["unregister", pkgid_str] -> do
pkgid <- readGlobPkgId pkgid_str
unregisterPackage pkgid verbosity cli force
@@ -782,11 +788,13 @@ registerPackage :: FilePath
-> Verbosity
-> [Flag]
-> Bool -- auto_ghci_libs
+ -> Bool -- multi_instance
-> Bool -- expand_env_vars
-> Bool -- update
-> Force
-> IO ()
-registerPackage input verbosity my_flags auto_ghci_libs expand_env_vars update force = do
+registerPackage input verbosity my_flags auto_ghci_libs multi_instance
+ expand_env_vars update force = do
(db_stack, Just to_modify, _flag_dbs) <-
getPkgDatabases verbosity True True False{-expand vars-} my_flags
@@ -829,10 +837,16 @@ registerPackage input verbosity my_flags auto_ghci_libs expand_env_vars update f
let truncated_stack = dropWhile ((/= to_modify).location) db_stack
-- truncate the stack for validation, because we don't allow
-- packages lower in the stack to refer to those higher up.
- validatePackageConfig pkg_expanded verbosity truncated_stack auto_ghci_libs update force
+ validatePackageConfig pkg_expanded verbosity truncated_stack
+ auto_ghci_libs multi_instance update force
let
+ -- In the normal mode, we only allow one version of each package, so we
+ -- remove all instances with the same source package id as the one we're
+ -- adding. In the multi instance mode we don't do that, thus allowing
+ -- multiple instances with the same source package id.
removes = [ RemovePackage p
- | p <- packages db_to_operate_on,
+ | not multi_instance,
+ p <- packages db_to_operate_on,
sourcePackageId p == sourcePackageId pkg ]
--
changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on
@@ -1204,7 +1218,8 @@ checkConsistency verbosity my_flags = do
let pkgs = allPackagesInStack db_stack
checkPackage p = do
- (_,es,ws) <- runValidate $ checkPackageConfig p verbosity db_stack False True
+ (_,es,ws) <- runValidate $ checkPackageConfig p verbosity db_stack
+ False True True
if null es
then do when (not simple_output) $ do
_ <- reportValidateErrors [] ws "" Nothing
@@ -1354,11 +1369,15 @@ validatePackageConfig :: InstalledPackageInfo
-> Verbosity
-> PackageDBStack
-> Bool -- auto-ghc-libs
+ -> Bool -- multi_instance
-> Bool -- update, or check
-> Force
-> IO ()
-validatePackageConfig pkg verbosity db_stack auto_ghci_libs update force = do
- (_,es,ws) <- runValidate $ checkPackageConfig pkg verbosity db_stack auto_ghci_libs update
+validatePackageConfig pkg verbosity db_stack auto_ghci_libs
+ multi_instance update force = do
+ (_,es,ws) <- runValidate $
+ checkPackageConfig pkg verbosity db_stack
+ auto_ghci_libs multi_instance update
ok <- reportValidateErrors es ws (display (sourcePackageId pkg) ++ ": ") (Just force)
when (not ok) $ exitWith (ExitFailure 1)
@@ -1366,12 +1385,14 @@ checkPackageConfig :: InstalledPackageInfo
-> Verbosity
-> PackageDBStack
-> Bool -- auto-ghc-libs
+ -> Bool -- multi_instance
-> Bool -- update, or check
-> Validate ()
-checkPackageConfig pkg verbosity db_stack auto_ghci_libs update = do
+checkPackageConfig pkg verbosity db_stack auto_ghci_libs
+ multi_instance update = do
checkInstalledPackageId pkg db_stack update
checkPackageId pkg
- checkDuplicates db_stack pkg update
+ checkDuplicates db_stack pkg multi_instance update
mapM_ (checkDep db_stack) (depends pkg)
checkDuplicateDepends (depends pkg)
mapM_ (checkDir False "import-dirs") (importDirs pkg)
@@ -1410,15 +1431,17 @@ checkPackageId ipi =
[] -> verror CannotForce ("invalid package identifier: " ++ str)
_ -> verror CannotForce ("ambiguous package identifier: " ++ str)
-checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Validate ()
-checkDuplicates db_stack pkg update = do
+checkDuplicates :: PackageDBStack -> InstalledPackageInfo
+ -> Bool -> Bool-> Validate ()
+checkDuplicates db_stack pkg multi_instance update = do
let
pkgid = sourcePackageId pkg
pkgs = packages (head db_stack)
--
-- Check whether this package id already exists in this DB
--
- when (not update && (pkgid `elem` map sourcePackageId pkgs)) $
+ when (not update && not multi_instance
+ && (pkgid `elem` map sourcePackageId pkgs)) $
verror CannotForce $
"package " ++ display pkgid ++ " is already installed"
More information about the ghc-commits
mailing list