diff --git a/testsuite/tests/cabal/cabal05/cabal05.stderr b/testsuite/tests/cabal/cabal05/cabal05.stderr
index eb51115ab081fec592d8b18bfc91940516417d2a..12a73340bf13a4960745396db6872ec0f2d8c953 100644
--- a/testsuite/tests/cabal/cabal05/cabal05.stderr
+++ b/testsuite/tests/cabal/cabal05/cabal05.stderr
@@ -1,3 +1,7 @@
+the following packages have broken abi-depends fields:
+ p
+ q
+ r
T.hs:3:1: error:
Ambiguous module name ‘Conflict’:
diff --git a/testsuite/tests/safeHaskell/check/pkg01/safePkg01.stdout b/testsuite/tests/safeHaskell/check/pkg01/safePkg01.stdout
index 59886cd378f17a7fc3235c1b411102d5263166be..6967d97ad65a09246f21f151b94cdc312623ed08 100644
--- a/testsuite/tests/safeHaskell/check/pkg01/safePkg01.stdout
+++ b/testsuite/tests/safeHaskell/check/pkg01/safePkg01.stdout
@@ -4,42 +4,42 @@ pdb.safePkg01/local.db
trusted: False
M_SafePkg
-package dependencies: base-4.9.0.0* ghc-prim-0.5.0.0 integer-gmp-1.0.0.0
+package dependencies: base-4.12.0.0* ghc-prim-0.5.3 integer-gmp-1.0.2.0
trusted: safe
require own pkg trusted: False
M_SafePkg2
-package dependencies: base-4.9.0.0 ghc-prim-0.5.0.0 integer-gmp-1.0.0.0
+package dependencies: base-4.12.0.0 ghc-prim-0.5.3 integer-gmp-1.0.2.0
trusted: trustworthy
require own pkg trusted: False
M_SafePkg3
-package dependencies: base-4.9.0.0* ghc-prim-0.5.0.0 integer-gmp-1.0.0.0
+package dependencies: base-4.12.0.0* ghc-prim-0.5.3 integer-gmp-1.0.2.0
trusted: safe
require own pkg trusted: True
M_SafePkg4
-package dependencies: base-4.9.0.0* ghc-prim-0.5.0.0 integer-gmp-1.0.0.0
+package dependencies: base-4.12.0.0* ghc-prim-0.5.3 integer-gmp-1.0.2.0
trusted: safe
require own pkg trusted: True
M_SafePkg5
-package dependencies: base-4.9.0.0* ghc-prim-0.5.0.0 integer-gmp-1.0.0.0
+package dependencies: base-4.12.0.0* ghc-prim-0.5.3 integer-gmp-1.0.2.0
trusted: safe
require own pkg trusted: True
M_SafePkg6
-package dependencies: array-0.5.1.0 base-4.9.0.0* bytestring-0.10.7.0* deepseq-1.4.2.0 ghc-prim-0.5.0.0 integer-gmp-1.0.0.0
+package dependencies: array-0.5.2.0 base-4.12.0.0* bytestring-0.10.8.2* deepseq-1.4.4.0 ghc-prim-0.5.3 integer-gmp-1.0.2.0
trusted: trustworthy
require own pkg trusted: False
M_SafePkg7
-package dependencies: array-0.5.1.0 base-4.9.0.0* bytestring-0.10.7.0* deepseq-1.4.2.0 ghc-prim-0.5.0.0 integer-gmp-1.0.0.0
+package dependencies: array-0.5.2.0 base-4.12.0.0* bytestring-0.10.8.2* deepseq-1.4.4.0 ghc-prim-0.5.3 integer-gmp-1.0.2.0
trusted: safe
require own pkg trusted: False
M_SafePkg8
-package dependencies: array-0.5.1.0 base-4.9.0.0 bytestring-0.10.7.0* deepseq-1.4.2.0 ghc-prim-0.5.0.0 integer-gmp-1.0.0.0
+package dependencies: array-0.5.2.0 base-4.12.0.0 bytestring-0.10.8.2* deepseq-1.4.4.0 ghc-prim-0.5.3 integer-gmp-1.0.2.0
trusted: trustworthy
require own pkg trusted: False
diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index a32252139fba97ec70f7a7e928ad7b096854d82a..69137eb4e4fde7f72edeea9245e49c5d2f0f857c 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -577,6 +577,15 @@ data DbModifySelector = TopOne | ContainsPkg PackageArg
allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo]
allPackagesInStack = concatMap packages
+-- | Retain only the part of the stack up to and including the given package
+-- DB (where the global package DB is the bottom of the stack). The resulting
+-- package DB stack contains exactly the packages that packages from the
+-- specified package DB can depend on, since dependencies can only extend
+-- down the stack, not up (e.g. global packages cannot depend on user
+-- packages).
+stackUpTo :: FilePath -> PackageDBStack -> PackageDBStack
+stackUpTo to_modify = dropWhile ((/= to_modify) . location)
+
getPkgDatabases :: Verbosity
-> GhcPkg.DbOpenMode mode DbModifySelector
-> Bool -- use the user db
@@ -1077,6 +1086,10 @@ initPackageDB filename verbosity _flags = do
packageDbLock = GhcPkg.DbOpenReadWrite lock,
packages = []
}
+ -- We can get away with passing an empty stack here, because the new DB is
+ -- going to be initially empty, so no dependencies are going to be actually
+ -- looked up.
+ []
-- -----------------------------------------------------------------------------
-- Registering
@@ -1126,7 +1139,7 @@ registerPackage input verbosity my_flags multi_instance
let top_dir = takeDirectory (location (last db_stack))
pkg_expanded = mungePackagePaths top_dir pkgroot pkg
- let truncated_stack = dropWhile ((/= to_modify).location) db_stack
+ let truncated_stack = stackUpTo to_modify 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
@@ -1144,7 +1157,7 @@ registerPackage input verbosity my_flags multi_instance
-- Only remove things that were instantiated the same way!
instantiatedWith p == instantiatedWith pkg ]
--
- changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on
+ changeDB verbosity (removes ++ [AddPackage pkg]) db_to_operate_on db_stack
parsePackageInfo
:: String
@@ -1169,12 +1182,16 @@ data DBOp = RemovePackage InstalledPackageInfo
| AddPackage InstalledPackageInfo
| ModifyPackage InstalledPackageInfo
-changeDB :: Verbosity -> [DBOp] -> PackageDB 'GhcPkg.DbReadWrite -> IO ()
-changeDB verbosity cmds db = do
+changeDB :: Verbosity
+ -> [DBOp]
+ -> PackageDB 'GhcPkg.DbReadWrite
+ -> PackageDBStack
+ -> IO ()
+changeDB verbosity cmds db db_stack = do
let db' = updateInternalDB db cmds
db'' <- adjustOldFileStylePackageDB db'
createDirectoryIfMissing True (location db'')
- changeDBDir verbosity cmds db''
+ changeDBDir verbosity cmds db'' db_stack
updateInternalDB :: PackageDB 'GhcPkg.DbReadWrite
-> [DBOp] -> PackageDB 'GhcPkg.DbReadWrite
@@ -1187,10 +1204,14 @@ updateInternalDB db cmds = db{ packages = foldl do_cmd (packages db) cmds }
do_cmd (do_cmd pkgs (RemovePackage p)) (AddPackage p)
-changeDBDir :: Verbosity -> [DBOp] -> PackageDB 'GhcPkg.DbReadWrite -> IO ()
-changeDBDir verbosity cmds db = do
+changeDBDir :: Verbosity
+ -> [DBOp]
+ -> PackageDB 'GhcPkg.DbReadWrite
+ -> PackageDBStack
+ -> IO ()
+changeDBDir verbosity cmds db db_stack = do
mapM_ do_cmd cmds
- updateDBCache verbosity db
+ updateDBCache verbosity db db_stack
where
do_cmd (RemovePackage p) = do
let file = location db </> display (installedUnitId p) <.> "conf"
@@ -1203,20 +1224,63 @@ changeDBDir verbosity cmds db = do
do_cmd (ModifyPackage p) =
do_cmd (AddPackage p)
-updateDBCache :: Verbosity -> PackageDB 'GhcPkg.DbReadWrite -> IO ()
-updateDBCache verbosity db = do
+updateDBCache :: Verbosity
+ -> PackageDB 'GhcPkg.DbReadWrite
+ -> PackageDBStack
+ -> IO ()
+updateDBCache verbosity db db_stack = do
let filename = location db </> cachefilename
+ db_stack_below = stackUpTo (location db) db_stack
pkgsCabalFormat :: [InstalledPackageInfo]
pkgsCabalFormat = packages db
- pkgsGhcCacheFormat :: [PackageCacheFormat]
- pkgsGhcCacheFormat = map convertPackageInfoToCacheFormat pkgsCabalFormat
+ -- | All the packages we can legally depend on in this step.
+ dependablePkgsCabalFormat :: [InstalledPackageInfo]
+ dependablePkgsCabalFormat = allPackagesInStack db_stack_below
+
+ pkgsGhcCacheFormat :: [(PackageCacheFormat, Bool)]
+ pkgsGhcCacheFormat
+ -- See Note [Recompute abi-depends]
+ = map (recomputeValidAbiDeps dependablePkgsCabalFormat)
+ $ map convertPackageInfoToCacheFormat
+ pkgsCabalFormat
+
+ hasAnyAbiDepends :: InstalledPackageInfo -> Bool
+ hasAnyAbiDepends x = length (abiDepends x) > 0
+
+ -- warn when we find any (possibly-)bogus abi-depends fields;
+ -- Note [Recompute abi-depends]
+ when (verbosity >= Normal) $ do
+ let definitelyBrokenPackages =
+ nub
+ . sort
+ . map (unPackageName . GhcPkg.packageName . fst)
+ . filter snd
+ $ pkgsGhcCacheFormat
+ when (definitelyBrokenPackages /= []) $ do
+ warn "the following packages have broken abi-depends fields:"
+ forM_ definitelyBrokenPackages $ \pkg ->
+ warn $ " " ++ pkg
+ when (verbosity > Normal) $ do
+ let possiblyBrokenPackages =
+ nub
+ . sort
+ . filter (not . (`elem` definitelyBrokenPackages))
+ . map (unPackageName . pkgName . packageId)
+ . filter hasAnyAbiDepends
+ $ pkgsCabalFormat
+ when (possiblyBrokenPackages /= []) $ do
+ warn $
+ "the following packages have correct abi-depends, " ++
+ "but may break in the future:"
+ forM_ possiblyBrokenPackages $ \pkg ->
+ warn $ " " ++ pkg
when (verbosity > Normal) $
infoLn ("writing cache " ++ filename)
- GhcPkg.writePackageDb filename pkgsGhcCacheFormat pkgsCabalFormat
+ GhcPkg.writePackageDb filename (map fst pkgsGhcCacheFormat) pkgsCabalFormat
`catchIO` \e ->
if isPermissionError e
then die $ filename ++ ": you don't have permission to modify this file"
@@ -1234,6 +1298,54 @@ type PackageCacheFormat = GhcPkg.InstalledPackageInfo
ModuleName
OpenModule
+{- Note [Recompute abi-depends]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Like most fields, `ghc-pkg` relies on who-ever is performing package
+registration to fill in fields; this includes the `abi-depends` field present
+for the package.
+
+However, this was likely a mistake, and is not very robust; in certain cases,
+versions of Cabal may use bogus abi-depends fields for a package when doing
+builds. Why? Because package database information is aggressively cached; it is
+possible to work Cabal into a situation where it uses a cached version of
+`abi-depends`, rather than the one in the actual database after it has been
+recomputed.
+
+However, there is an easy fix: ghc-pkg /already/ knows the `abi-depends` of a
+package, because they are the ABIs of the packages pointed at by the `depends`
+field. So it can simply look up the abi from the dependencies in the original
+database, and ignore whatever the system registering gave it.
+
+So, instead, we do two things here:
+
+ - We throw away the information for a registered package's `abi-depends` field.
+
+ - We recompute it: we simply look up the unit ID of the package in the original
+ database, and use *its* abi-depends.
+
+See Trac #14381, and Cabal issue #4728.
+
+Additionally, because we are throwing away the original (declared) ABI deps, we
+return a boolean that indicates whether any abi-depends were actually
+overridden.
+
+-}
+
+recomputeValidAbiDeps :: [InstalledPackageInfo]
+ -> PackageCacheFormat
+ -> (PackageCacheFormat, Bool)
+recomputeValidAbiDeps db pkg =
+ (pkg { GhcPkg.abiDepends = newAbiDeps }, abiDepsUpdated)
+ where
+ newAbiDeps =
+ catMaybes . flip map (GhcPkg.abiDepends pkg) $ \(k, _) ->
+ case filter (\d -> installedUnitId d == k) db of
+ [x] -> Just (k, unAbiHash (abiHash x))
+ _ -> Nothing
+ abiDepsUpdated =
+ GhcPkg.abiDepends pkg /= newAbiDeps
+
convertPackageInfoToCacheFormat :: InstalledPackageInfo -> PackageCacheFormat
convertPackageInfoToCacheFormat pkg =
GhcPkg.InstalledPackageInfo {
@@ -1371,14 +1483,14 @@ modifyPackage fn pkgarg verbosity my_flags force = do
dieOrForceAll force ("unregistering would break the following packages: "
++ unwords (map displayQualPkgId newly_broken))
- changeDB verbosity cmds db
+ changeDB verbosity cmds db db_stack
recache :: Verbosity -> [Flag] -> IO ()
recache verbosity my_flags = do
(_db_stack, GhcPkg.DbOpenReadWrite db_to_operate_on, _flag_dbs) <-
getPkgDatabases verbosity (GhcPkg.DbOpenReadWrite TopOne)
True{-use user-} False{-no cache-} False{-expand vars-} my_flags
- changeDB verbosity [] db_to_operate_on
+ changeDB verbosity [] db_to_operate_on _db_stack
-- -----------------------------------------------------------------------------
-- Listing packages