HPC artifacts are written and read from pkg-db

This commit re-designs the mechanism by which we make the .mix files of
libraries available to produce the Haskell Program Coverage report after
running testsuites.

The idea, for the Cabal library, is:

* Cabal builds libraries with -fhpc, and store the hpc artifacts in
  build </> `extraCompilationArtifacts`
* At Cabal install time, `extraCompilationArtifacts` is copied into the
  package database
* At Cabal configure time, we both
    - receive as --coverage-for flags unit-ids of library components
      from the same package (ultimately, when #9493 is resolved, we will
      receive unit ids of libraries in other packages in the same
      project too),
    - and, when configuring a whole package instead of just a testsuite
      component, we determine the unit-ids of libraries in the package
  these unit-ids are written into `configCoverageFor` in `ConfigFlags`
* At Cabal test time, for each library to cover (stored in
  `configCoverageFor`), we look in the package database for the hpc
  dirs, which we eventually pass along to the `hpc markup` call as
  `--hpcdir` flags

As for cabal-install:

* After a plan has been elaborated, we select the packages which can be
  covered and pass them to Cabal's ./Setup configure as
  --coverage-for=<unit-id> flags.
    - Notably, valid libraries are non-indefinite and
      non-instantiations, since HPC does not support backpack.
    - Furthermore, we only include libraries in the same package as the
      component being configured, despite possibly there being
      more library components in other packages of the same project.
      When #9493 is resolved, we could lift this restriction and pass
      all libraries local to the package as --coverage-for. See
      `determineCoverageFor` and `shouldCoverPkg` in Distribution.Client.ProjectPlanning.

Detail:
    We no longer pass the path to the testsuite's mix dirs to `hpc
    markup` because we only ever include modules in libraries, which
    means they were previously unused.

Fixes #6440 (internal libs coverage), #6397 (backpack breaks coverage),
doesn't yet fix #8609 (multi-package coverage report) which is tracked
in #9493, and fixes in a new way the previously fixed #4798, #5213.

Author: alt-romes

Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs

@@ -43,5 +43,5 @@ md5CheckLocalBuildInfo proxy = md5Check proxy
 #if MIN_VERSION_base(4,19,0)
     0x23942cff98237dc167ef90d64d7ef893
 #else
-    0xa4e9f8a7e1583906880d6ec2d1bbb14b
+    0xc6c0cc122cc60ce7943764cbaaacdc2d
 #endif

Cabal/src/Distribution/Simple/Configure.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE RecordWildCards #-}
@@ -44,6 +46,7 @@ module Distribution.Simple.Configure
   , localBuildInfoFile
   , getInstalledPackages
   , getInstalledPackagesMonitorFiles
+  , getInstalledPackagesById
   , getPackageDBContents
   , configCompilerEx
   , configCompilerAuxEx
@@ -56,6 +59,7 @@ module Distribution.Simple.Configure
   , platformDefines
   ) where
 
+import Control.Monad
 import Distribution.Compat.Prelude
 import Prelude ()
 
@@ -78,7 +82,7 @@ import Distribution.Simple.BuildTarget
 import Distribution.Simple.BuildToolDepends
 import Distribution.Simple.Compiler
 import Distribution.Simple.LocalBuildInfo
-import Distribution.Simple.PackageIndex (InstalledPackageIndex)
+import Distribution.Simple.PackageIndex (InstalledPackageIndex, lookupUnitId)
 import qualified Distribution.Simple.PackageIndex as PackageIndex
 import Distribution.Simple.PreProcess
 import Distribution.Simple.Program
@@ -162,6 +166,7 @@ import qualified Data.Maybe as M
 import qualified Data.Set as Set
 import qualified Distribution.Compat.NonEmptySet as NES
 import Distribution.Simple.Errors
+import Distribution.Simple.Flag (mergeListFlag)
 import Distribution.Types.AnnotatedId
 
 type UseExternalInternalDeps = Bool
@@ -877,10 +882,21 @@ configure (pkg_descr0, pbi) cfg = do
           Map.empty
           buildComponents
 
+  -- For whole-package configure, we have to determine the additional
+  -- configCoverageFor of the main lib and sub libs here.
+  let extraCoverageFor :: [UnitId] = case enabled of
+        -- Whole package configure, add package libs
+        ComponentRequestedSpec{} -> mapMaybe (\case LibComponentLocalBuildInfo{componentUnitId} -> Just componentUnitId; _ -> Nothing) buildComponents
+        -- Component configure, no need to do anything
+        OneComponentRequestedSpec{} -> []
+
+  -- TODO: Should we also enforce something here on that --coverage-for cannot
+  -- include indefinite components or instantiations?
+
   let lbi =
         (setCoverageLBI . setProfLBI)
           LocalBuildInfo
-            { configFlags = cfg
+            { configFlags = cfg{configCoverageFor = mergeListFlag (configCoverageFor cfg) (toFlag extraCoverageFor)}
             , flagAssignment = flags
             , componentEnabledSpec = enabled
             , extraConfigArgs = [] -- Currently configure does not
@@ -1747,6 +1763,28 @@ getInstalledPackagesMonitorFiles verbosity comp packageDBs progdb platform =
           ++ prettyShow other
       return []
 
+-- | Looks up the 'InstalledPackageInfo' of the given 'UnitId's from the
+-- 'PackageDBStack' in the 'LocalBuildInfo'.
+getInstalledPackagesById
+  :: (Exception (VerboseException exception), Show exception, Typeable exception)
+  => Verbosity
+  -> LocalBuildInfo
+  -> (UnitId -> exception)
+  -- ^ Construct an exception that is thrown if a
+  -- unit-id is not found in the installed packages,
+  -- from the unit-id that is missing.
+  -> [UnitId]
+  -- ^ The unit ids to lookup in the installed packages
+  -> IO [InstalledPackageInfo]
+getInstalledPackagesById verbosity LocalBuildInfo{compiler, withPackageDB, withPrograms} mkException unitids = do
+  ipindex <- getInstalledPackages verbosity compiler withPackageDB withPrograms
+  mapM
+    ( \uid -> case lookupUnitId ipindex uid of
+        Nothing -> dieWithException verbosity (mkException uid)
+        Just ipkg -> return ipkg
+    )
+    unitids
+
 -- | The user interface specifies the package dbs to use with a combination of
 -- @--global@, @--user@ and @--package-db=global|user|clear|$file@.
 -- This function combines the global/user flag and interprets the package-db

Cabal/src/Distribution/Simple/Errors.hs

@@ -170,6 +170,7 @@ data CabalException
   | NoProgramFound String VersionRange
   | BadVersionDb String Version VersionRange FilePath
   | UnknownVersionDb String VersionRange FilePath
+  | MissingCoveredInstalledLibrary UnitId
   deriving (Show, Typeable)
 
 exceptionCode :: CabalException -> Int
@@ -301,6 +302,7 @@ exceptionCode e = case e of
   NoProgramFound{} -> 7620
   BadVersionDb{} -> 8038
   UnknownVersionDb{} -> 1008
+  MissingCoveredInstalledLibrary{} -> 9341
 
 versionRequirement :: VersionRange -> String
 versionRequirement range
@@ -791,3 +793,7 @@ exceptionMessage e = case e of
       ++ " is required but the version of "
       ++ locationPath
       ++ " could not be determined."
+  MissingCoveredInstalledLibrary unitId ->
+    "Failed to find the installed unit '"
+      ++ prettyShow unitId
+      ++ "' in package database stack."

Cabal/src/Distribution/Simple/GHC/BuildGeneric.hs

@@ -19,7 +19,6 @@ import Distribution.PackageDescription.Utils (cabalBug)
 import Distribution.Pretty
 import Distribution.Simple.BuildPaths
 import Distribution.Simple.Compiler
-import Distribution.Simple.Flag (Flag (..), fromFlag, toFlag)
 import Distribution.Simple.GHC.Build
   ( checkNeedsRecompilation
   , componentGhcOptions
@@ -39,7 +38,7 @@ import Distribution.Simple.LocalBuildInfo
 import qualified Distribution.Simple.PackageIndex as PackageIndex
 import Distribution.Simple.Program
 import Distribution.Simple.Program.GHC
-import Distribution.Simple.Setup.Config
+import Distribution.Simple.Setup.Common
 import Distribution.Simple.Setup.Repl
 import Distribution.Simple.Utils
 import Distribution.System
@@ -399,10 +398,9 @@ gbuild verbosity numJobs pkg_descr lbi bm clbi = do
   -- Determine if program coverage should be enabled and if so, what
   -- '-hpcdir' should be.
   let isCoverageEnabled = exeCoverage lbi
-      distPref = fromFlag $ configDistPref $ configFlags lbi
       hpcdir way
         | gbuildIsRepl bm = mempty -- HPC is not supported in ghci
-        | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way
+        | isCoverageEnabled = toFlag $ Hpc.mixDir (tmpDir </> extraCompilationArtifacts) way
         | otherwise = mempty
 
   rpaths <- getRPaths lbi clbi

Cabal/src/Distribution/Simple/GHC/BuildOrRepl.hs

@@ -9,7 +9,6 @@ import Distribution.Package
 import Distribution.PackageDescription as PD
 import Distribution.Simple.BuildPaths
 import Distribution.Simple.Compiler
-import Distribution.Simple.Flag (Flag (..), fromFlag, toFlag)
 import Distribution.Simple.GHC.Build
   ( checkNeedsRecompilation
   , componentGhcOptions
@@ -27,7 +26,7 @@ import Distribution.Simple.Program
 import qualified Distribution.Simple.Program.Ar as Ar
 import Distribution.Simple.Program.GHC
 import qualified Distribution.Simple.Program.Ld as Ld
-import Distribution.Simple.Setup.Config
+import Distribution.Simple.Setup.Common
 import Distribution.Simple.Setup.Repl
 import Distribution.Simple.Utils
 import Distribution.System
@@ -96,10 +95,9 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do
   -- Determine if program coverage should be enabled and if so, what
   -- '-hpcdir' should be.
   let isCoverageEnabled = libCoverage lbi
-      distPref = fromFlag $ configDistPref $ configFlags lbi
       hpcdir way
         | forRepl = mempty -- HPC is not supported in ghci
-        | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way
+        | isCoverageEnabled = toFlag $ Hpc.mixDir (libTargetDir </> extraCompilationArtifacts) way
         | otherwise = mempty
 
   createDirectoryIfMissingVerbose verbosity True libTargetDir

Cabal/src/Distribution/Simple/GHCJS.hs

@@ -72,7 +72,7 @@ import Distribution.Simple.Program
 import Distribution.Simple.Program.GHC
 import qualified Distribution.Simple.Program.HcPkg as HcPkg
 import qualified Distribution.Simple.Program.Strip as Strip
-import Distribution.Simple.Setup.Config
+import Distribution.Simple.Setup.Common
 import Distribution.Simple.Utils
 import Distribution.System
 import Distribution.Types.ComponentLocalBuildInfo
@@ -515,10 +515,9 @@ buildOrReplLib mReplFlags verbosity numJobs _pkg_descr lbi lib clbi = do
   -- Determine if program coverage should be enabled and if so, what
   -- '-hpcdir' should be.
   let isCoverageEnabled = libCoverage lbi
-      distPref = fromFlag $ configDistPref $ configFlags lbi
       hpcdir way
         | forRepl = mempty -- HPC is not supported in ghci
-        | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way
+        | isCoverageEnabled = toFlag $ Hpc.mixDir (libTargetDir </> extraCompilationArtifacts) way
         | otherwise = mempty
 
   createDirectoryIfMissingVerbose verbosity True libTargetDir
@@ -1235,10 +1234,9 @@ gbuild verbosity numJobs pkg_descr lbi bm clbi = do
   -- Determine if program coverage should be enabled and if so, what
   -- '-hpcdir' should be.
   let isCoverageEnabled = exeCoverage lbi
-      distPref = fromFlag $ configDistPref $ configFlags lbi
       hpcdir way
         | gbuildIsRepl bm = mempty -- HPC is not supported in ghci
-        | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way
+        | isCoverageEnabled = toFlag $ Hpc.mixDir (tmpDir </> extraCompilationArtifacts) way
         | otherwise = mempty
 
   rpaths <- getRPaths lbi clbi

Cabal/src/Distribution/Simple/Hpc.hs

@@ -22,27 +22,26 @@ module Distribution.Simple.Hpc
   , mixDir
   , tixDir
   , tixFilePath
+  , HPCMarkupInfo (..)
   , markupPackage
   ) where
 
 import Distribution.Compat.Prelude
 import Prelude ()
 
-import Distribution.ModuleName (main)
+import Distribution.ModuleName (ModuleName, main)
 import Distribution.PackageDescription
   ( TestSuite (..)
   , testModules
   )
 import qualified Distribution.PackageDescription as PD
 import Distribution.Pretty
-import Distribution.Simple.Flag (fromFlagOrDefault)
 import Distribution.Simple.LocalBuildInfo (LocalBuildInfo (..))
 import Distribution.Simple.Program
   ( hpcProgram
   , requireProgramVersion
   )
 import Distribution.Simple.Program.Hpc (markup, union)
-import Distribution.Simple.Setup (TestFlags (..))
 import Distribution.Simple.Utils (notice)
 import Distribution.Types.UnqualComponentName
 import Distribution.Verbosity (Verbosity ())
@@ -112,17 +111,27 @@ guessWay lbi
   | withDynExe lbi = Dyn
   | otherwise = Vanilla
 
+-- | Haskell Program Coverage information required to produce a valid HPC
+-- report through the `hpc markup` call for the package libraries.
+data HPCMarkupInfo = HPCMarkupInfo
+  { pathsToLibsArtifacts :: [FilePath]
+  -- ^ The paths to the library components whose modules are included in the
+  -- coverage report
+  , libsModulesToInclude :: [ModuleName]
+  -- ^ The modules to include in the coverage report
+  }
+
 -- | Generate the HTML markup for a package's test suites.
 markupPackage
   :: Verbosity
-  -> TestFlags
+  -> HPCMarkupInfo
   -> LocalBuildInfo
   -> FilePath
   -- ^ Testsuite \"dist/\" prefix
   -> PD.PackageDescription
   -> [TestSuite]
   -> IO ()
-markupPackage verbosity TestFlags{testCoverageDistPrefs, testCoverageLibsModules} lbi testDistPref pkg_descr suites = do
+markupPackage verbosity HPCMarkupInfo{pathsToLibsArtifacts, libsModulesToInclude} lbi testDistPref pkg_descr suites = do
   let tixFiles = map (tixFilePath testDistPref way) testNames
   tixFilesExist <- traverse doesFileExist tixFiles
   when (and tixFilesExist) $ do
@@ -160,13 +169,12 @@ markupPackage verbosity TestFlags{testCoverageDistPrefs, testCoverageLibsModules
         union hpc verbosity tixFiles summedTixFile excluded
         return summedTixFile
 
-    markup hpc hpcVer verbosity tixFile mixDirs htmlDir' included
+    markup hpc hpcVer verbosity tixFile mixDirs htmlDir' libsModulesToInclude
     notice verbosity $
       "Package coverage report written to "
         ++ htmlDir'
         </> "hpc_index.html"
   where
     way = guessWay lbi
     testNames = fmap (unUnqualComponentName . testName) suites
-    mixDirs = map (`mixDir` way) (fromFlagOrDefault [] testCoverageDistPrefs)
-    included = fromFlagOrDefault [] testCoverageLibsModules
+    mixDirs = map (`mixDir` way) pathsToLibsArtifacts

Cabal/src/Distribution/Simple/Setup/Config.hs

@@ -54,6 +54,7 @@ import Distribution.Types.DumpBuildInfo
 import Distribution.Types.GivenComponent
 import Distribution.Types.Module
 import Distribution.Types.PackageVersionConstraint
+import Distribution.Types.UnitId
 import Distribution.Utils.NubList
 import Distribution.Verbosity
 import qualified Text.PrettyPrint as Disp
@@ -220,6 +221,11 @@ data ConfigFlags = ConfigFlags
   -- ^ Allow depending on private sublibraries. This is used by external
   -- tools (like cabal-install) so they can add multiple-public-libraries
   -- compatibility to older ghcs by checking visibility externally.
+  , configCoverageFor :: Flag [UnitId]
+  -- ^ The list of libraries to be included in the hpc coverage report for
+  -- testsuites run with @--enable-coverage@. Notably, this list must exclude
+  -- indefinite libraries and instantiations because HPC does not support
+  -- backpack (Nov. 2023).
   }
   deriving (Generic, Read, Show, Typeable)
 
@@ -288,6 +294,7 @@ instance Eq ConfigFlags where
       && equal configDebugInfo
       && equal configDumpBuildInfo
       && equal configUseResponseFiles
+      && equal configCoverageFor
     where
       equal f = on (==) f a b
 
@@ -828,6 +835,22 @@ configureOptions showOrParseArgs =
           configAllowDependingOnPrivateLibs
           (\v flags -> flags{configAllowDependingOnPrivateLibs = v})
           trueArg
+       , option
+          ""
+          ["coverage-for"]
+          "A list of unit-ids of libraries to include in the Haskell Program Coverage report."
+          configCoverageFor
+          ( \v flags ->
+              flags
+                { configCoverageFor =
+                    mergeListFlag (configCoverageFor flags) v
+                }
+          )
+          ( reqArg'
+              "UNITID"
+              (Flag . (: []) . fromString)
+              (fmap prettyShow . fromFlagOrDefault [])
+          )
        ]
   where
     liftInstallDirs =