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 haskell#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 haskell#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.

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

@@ -41,7 +41,7 @@ md5CheckGenericPackageDescription proxy = md5Check proxy
 md5CheckLocalBuildInfo :: Proxy LocalBuildInfo -> Assertion
 md5CheckLocalBuildInfo proxy = md5Check proxy
 #if MIN_VERSION_base(4,19,0)
-    0x205fbe2649bc5e488bce50c07a71cadb
+    0x512e880894570552f08aa82547568dbc
 #else
-    0x26e91a71ebd19d4d6ce37f798ede249a
+    0x968807984ad42d41a9e9ab696a9fec58
 #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
+  , getInstalledPackageById
   , getPackageDBContents
   , configCompilerEx
   , configCompilerAuxEx
@@ -78,7 +81,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 +165,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 +881,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 +1762,17 @@ getInstalledPackagesMonitorFiles verbosity comp packageDBs progdb platform =
           ++ prettyShow other
       return []
 
+-- | Looks up the 'InstalledPackageInfo' of a given 'UnitId' from the
+-- 'PackageDBStack' in the 'LocalBuildInfo'.
+getInstalledPackageById :: Verbosity -> LocalBuildInfo -> UnitId -> IO (Maybe InstalledPackageInfo)
+getInstalledPackageById verbosity LocalBuildInfo{compiler, withPackageDB, withPrograms} unitid = do
+  ipindex <- getInstalledPackages verbosity compiler withPackageDB withPrograms
+  putStrLn "GET INSTALLED PACKAGES"
+  print ipindex
+  putStrLn "PKG DB"
+  print withPackageDB
+  return $ lookupUnitId ipindex unitid
+
 -- | 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/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

@@ -28,21 +28,19 @@ module Distribution.Simple.Hpc
 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 ())
@@ -115,14 +113,15 @@ guessWay lbi
 -- | Generate the HTML markup for a package's test suites.
 markupPackage
   :: Verbosity
-  -> TestFlags
+  -> [FilePath]
+  -> [ModuleName]
   -> LocalBuildInfo
   -> FilePath
   -- ^ Testsuite \"dist/\" prefix
   -> PD.PackageDescription
   -> [TestSuite]
   -> IO ()
-markupPackage verbosity TestFlags{testCoverageDistPrefs, testCoverageLibsModules} lbi testDistPref pkg_descr suites = do
+markupPackage verbosity testCoverageDistPrefs testCoverageLibsModules lbi testDistPref pkg_descr suites = do
   let tixFiles = map (tixFilePath testDistPref way) testNames
   tixFilesExist <- traverse doesFileExist tixFiles
   when (and tixFilesExist) $ do
@@ -168,5 +167,5 @@ markupPackage verbosity TestFlags{testCoverageDistPrefs, testCoverageLibsModules
   where
     way = guessWay lbi
     testNames = fmap (unUnqualComponentName . testName) suites
-    mixDirs = map (`mixDir` way) (fromFlagOrDefault [] testCoverageDistPrefs)
-    included = fromFlagOrDefault [] testCoverageLibsModules
+    mixDirs = map (`mixDir` way) (testCoverageDistPrefs)
+    included = testCoverageLibsModules

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 =

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

@@ -40,7 +40,6 @@ import Distribution.Simple.Utils
 import Distribution.Verbosity
 import qualified Text.PrettyPrint as Disp
 
-import Distribution.ModuleName (ModuleName)
 import Distribution.Simple.Setup.Common
 
 -- ------------------------------------------------------------
@@ -89,15 +88,6 @@ data TestFlags = TestFlags
   , testKeepTix :: Flag Bool
   , testWrapper :: Flag FilePath
   , testFailWhenNoTestSuites :: Flag Bool
-  , testCoverageLibsModules :: Flag [ModuleName]
-  -- ^ The list of all modules from libraries in the local project that should
-  -- be included in the hpc coverage report.
-  , testCoverageDistPrefs :: Flag [FilePath]
-  -- ^ The path to each library local to this project and to the test
-  -- components being built, to include in coverage reporting (notably, this
-  -- excludes indefinite libraries and instantiations because HPC does not
-  -- support backpack - Nov. 2023).  Cabal uses these paths as dist prefixes to
-  -- determine the path to the `mix` dirs of each component to cover.
   , -- TODO: think about if/how options are passed to test exes
     testOptions :: [PathTemplate]
   }
@@ -114,8 +104,6 @@ defaultTestFlags =
     , testKeepTix = toFlag False
     , testWrapper = NoFlag
     , testFailWhenNoTestSuites = toFlag False
-    , testCoverageLibsModules = NoFlag
-    , testCoverageDistPrefs = NoFlag
     , testOptions = []
     }
 
@@ -221,38 +209,6 @@ testOptions' showOrParseArgs =
       testFailWhenNoTestSuites
       (\v flags -> flags{testFailWhenNoTestSuites = v})
       trueArg
-  , option
-      []
-      ["coverage-module"]
-      "Module of a project-local library to include in the HPC report"
-      testCoverageLibsModules
-      ( \v flags ->
-          flags
-            { testCoverageLibsModules =
-                mergeListFlag (testCoverageLibsModules flags) v
-            }
-      )
-      ( reqArg'
-          "MODULE"
-          (Flag . (: []) . fromString)
-          (fmap prettyShow . fromFlagOrDefault [])
-      )
-  , option
-      []
-      ["coverage-dist-dir"]
-      "The directory where Cabal puts generated build files of an HPC enabled component"
-      testCoverageDistPrefs
-      ( \v flags ->
-          flags
-            { testCoverageDistPrefs =
-                mergeListFlag (testCoverageDistPrefs flags) v
-            }
-      )
-      ( reqArg'
-          "DIR"
-          (Flag . (: []))
-          (fromFlagOrDefault [])
-      )
   , option
       []
       ["test-options"]