ghc-pkg: properly recompute `abi-depends` for updated packages.wip/T14381

The `abi-depends:` Cabal field turns out to be problematic due to cached
package dependencies; from the perspective of ghc-pkg, this field is
unreliable, and also redundant, because the required information is
already available in the existing package database.

So we do the following:

- Ignore declared abi-depends
- Infer correct abi-depends from existing package data
- Warn about any packages that declare abi-depends that differ from what
  we inferred
- In verbose mode, warn about any packages that declare abi-depends at
  all.

Previous work on this had been done in 1cdc14f9c0, however, that
solution suffered from a few minor drawbacks which we fix here:

- The previous solution only looked at the current package database; we
  now inspect the entire stack of databases, to correctly reflect
  possible dependencies.
- We now output warnings on stderr, not stdout.
- When issuing a warning, we list the offending packages (otherwise, the
  warning wouldn't be very useful in practice).
- By default, we only warn about packages that deviate (declare
  abi-depends /= inferred abi-depends).
- Warnings can now be controlled through verbosity.
- Testsuite reflects new situation.

3 files changed, 139 insertions, 23 deletions

diff --git a/testsuite/tests/cabal/cabal05/cabal05.stderr b/testsuite/tests/cabal/cabal05/cabal05.stderr
index eb51115ab0..12a73340bf 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 59886cd378..6967d97ad6 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 a32252139f..69137eb4e4 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