Commit dd3a7245 authored by Austin Seipp's avatar Austin Seipp

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
parent 423caa85
......@@ -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"
......
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