Per-component multi-package builds with coverage enabled

This commits re-enables per-component builds when coverage checking is
enabled. This restriction was previously added in #5004 to fix #4798.

- #4798 was subsequently fixed "again" with the fix for #5213, in #7493 by
fixing the paths of the testsuite `.mix` files to the same location as
that of the main library component.

Therefore the restriction to treat testsuites per-package
(legacy-fallback) is no longer needed.

We went further and fixed coverage for internal sublibraries, packages
with backpack (but without generating coverage information for
indefinite and instantiated units -- it is not clear what it would mean
for HPC to support this), and coverage for multi-package projects.

1. We allow hpc in per-component builds

2. To generate hpc files in the appropriate component directories in the
distribution tree, we remove the hack from #7493 and instead determine
the `.mix` directories that are included in the call to `hpc markup` by
passing the list of libraries in the project from the cabal-install
invocation of test.
We also drop an unnecessary directory in the hpc file hierarchy.

3. To account for internal (non-backpack) libraries, we include the mix
   dirs and modules of all (non-indefinite and non-instantiations)
   libraries in the project

   Indefinite libraries and instantiations are ignored as it is not
   obvious what it means for HPC to support backpack, e.g. covering a
   library function that two different instantiations

4. We now only reject coverage if there are no libraries at all in the
   project, rather than if there are no libraries in the package.

This allows us to drop the coverage masking logic in
cabal.project.coverage while still having coverage of cabal-install
(i.e. cabal test --enable-coverage cabal-install now works without the
workaround)

Even though we allow multi-package project coverage, we still cover each
package independently -- the tix files resulting from all packages are
not combined for the time being.

Includes tests for #6440, #6397, #8609, and #4798 (the test for #5213 already exists)

Fixes #6440 (internal libs coverage), #6397 (backpack breaks coverage)
, #8609 (multi-package coverage report) and fixes in a new way the
previously fixed #4798, #5213.

Author: alt-romes

Cabal/src/Distribution/Simple/Errors.hs

@@ -715,12 +715,12 @@ exceptionMessage e = case e of
     "Could not find test program \""
       ++ cmd
       ++ "\". Did you build the package first?"
-  TestCoverageSupport -> "Test coverage is only supported for packages with a library component."
+  TestCoverageSupport -> "Test coverage is only supported for projects with at least one (non-backpack) library component."
   Couldn'tFindTestProgLibV09 cmd ->
     "Could not find test program \""
       ++ cmd
       ++ "\". Did you build the package first?"
-  TestCoverageSupportLibV09 -> "Test coverage is only supported for packages with a library component."
+  TestCoverageSupportLibV09 -> "Test coverage is only supported for projects with at least one (non-backpack) library component."
   RawSystemStdout errors -> errors
   FindFileCwd fileName -> fileName ++ " doesn't exist"
   FindFileEx fileName -> fileName ++ " doesn't exist"

Cabal/src/Distribution/Simple/GHC.hs

@@ -643,15 +643,10 @@ 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
-      -- TODO: Historically HPC files have been put into a directory which
-      -- has the package name.  I'm going to avoid changing this for
-      -- now, but it would probably be better for this to be the
-      -- component ID instead...
-      pkg_name = prettyShow (PD.package pkg_descr)
       distPref = fromFlag $ configDistPref $ configFlags lbi
       hpcdir way
         | forRepl = mempty -- HPC is not supported in ghci
-        | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way pkg_name
+        | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way
         | otherwise = mempty
 
   createDirectoryIfMissingVerbose verbosity True libTargetDir
@@ -1548,7 +1543,7 @@ gbuild verbosity numJobs pkg_descr lbi bm clbi = do
       distPref = fromFlag $ configDistPref $ configFlags lbi
       hpcdir way
         | gbuildIsRepl bm = mempty -- HPC is not supported in ghci
-        | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way (gbuildName bm)
+        | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way
         | otherwise = mempty
 
   rpaths <- getRPaths lbi clbi

Cabal/src/Distribution/Simple/GHCJS.hs

@@ -481,7 +481,7 @@ buildOrReplLib
   -> Library
   -> ComponentLocalBuildInfo
   -> IO ()
-buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do
+buildOrReplLib mReplFlags verbosity numJobs _pkg_descr lbi lib clbi = do
   let uid = componentUnitId clbi
       libTargetDir = componentBuildDir lbi clbi
       whenVanillaLib forceVanilla =
@@ -515,15 +515,10 @@ 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
-      -- TODO: Historically HPC files have been put into a directory which
-      -- has the package name.  I'm going to avoid changing this for
-      -- now, but it would probably be better for this to be the
-      -- component ID instead...
-      pkg_name = prettyShow (PD.package pkg_descr)
       distPref = fromFlag $ configDistPref $ configFlags lbi
       hpcdir way
         | forRepl = mempty -- HPC is not supported in ghci
-        | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way pkg_name
+        | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way
         | otherwise = mempty
 
   createDirectoryIfMissingVerbose verbosity True libTargetDir
@@ -1243,7 +1238,7 @@ gbuild verbosity numJobs pkg_descr lbi bm clbi = do
       distPref = fromFlag $ configDistPref $ configFlags lbi
       hpcdir way
         | gbuildIsRepl bm = mempty -- HPC is not supported in ghci
-        | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way (gbuildName bm)
+        | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way
         | otherwise = mempty
 
   rpaths <- getRPaths lbi clbi

Cabal/src/Distribution/Simple/Hpc.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE NamedFieldPuns #-}
 
 -----------------------------------------------------------------------------
 
@@ -22,16 +23,14 @@ module Distribution.Simple.Hpc
   , tixDir
   , tixFilePath
   , markupPackage
-  , markupTest
   ) where
 
 import Distribution.Compat.Prelude
 import Prelude ()
 
 import Distribution.ModuleName (main)
 import Distribution.PackageDescription
-  ( Library (..)
-  , TestSuite (..)
+  ( TestSuite (..)
   , testModules
   )
 import qualified Distribution.PackageDescription as PD
@@ -48,6 +47,8 @@ import Distribution.Verbosity (Verbosity ())
 import Distribution.Version (anyVersion)
 import System.Directory (createDirectoryIfMissing, doesFileExist)
 import System.FilePath
+import Distribution.Simple.Setup (TestFlags(..))
+import Distribution.Simple.Flag (fromFlagOrDefault)
 
 -- -------------------------------------------------------------------------
 -- Haskell Program Coverage
@@ -73,44 +74,16 @@ mixDir
   -- ^ \"dist/\" prefix
   -> Way
   -> FilePath
-  -- ^ Component name
-  -> FilePath
   -- ^ Directory containing test suite's .mix files
-mixDir distPref way name = hpcDir distPrefBuild way </> "mix" </> name
-  where
-    -- This is a hack for HPC over test suites, needed to match the directory
-    -- where HPC saves and reads .mix files when the main library of the same
-    -- package is being processed, perhaps in a previous cabal run (#5213).
-    -- E.g., @distPref@ may be
-    -- @./dist-newstyle/build/x86_64-linux/ghc-9.0.1/cabal-gh5213-0.1/t/tests@
-    -- but the path where library mix files reside has two less components
-    -- at the end (@t/tests@) and this reduced path needs to be passed to
-    -- both @hpc@ and @ghc@. For non-default optimization levels, the path
-    -- suffix is one element longer and the extra path element needs
-    -- to be preserved.
-    distPrefElements = splitDirectories distPref
-    distPrefBuild = case drop (length distPrefElements - 3) distPrefElements of
-      ["t", _, "noopt"] ->
-        joinPath $
-          take (length distPrefElements - 3) distPrefElements
-            ++ ["noopt"]
-      ["t", _, "opt"] ->
-        joinPath $
-          take (length distPrefElements - 3) distPrefElements
-            ++ ["opt"]
-      [_, "t", _] ->
-        joinPath $ take (length distPrefElements - 2) distPrefElements
-      _ -> distPref
+mixDir distPref way = hpcDir distPref way </> "mix"
 
 tixDir
   :: FilePath
   -- ^ \"dist/\" prefix
   -> Way
   -> FilePath
-  -- ^ Component name
-  -> FilePath
   -- ^ Directory containing test suite's .tix files
-tixDir distPref way name = hpcDir distPref way </> "tix" </> name
+tixDir distPref way = hpcDir distPref way </> "tix"
 
 -- | Path to the .tix file containing a test suite's sum statistics.
 tixFilePath
@@ -121,17 +94,15 @@ tixFilePath
   -- ^ Component name
   -> FilePath
   -- ^ Path to test suite's .tix file
-tixFilePath distPref way name = tixDir distPref way name </> name <.> "tix"
+tixFilePath distPref way name = tixDir distPref way </> name <.> "tix"
 
 htmlDir
   :: FilePath
   -- ^ \"dist/\" prefix
   -> Way
   -> FilePath
-  -- ^ Component name
-  -> FilePath
   -- ^ Path to test suite's HTML markup directory
-htmlDir distPref way name = hpcDir distPref way </> "html" </> name
+htmlDir distPref way = hpcDir distPref way </> "html"
 
 -- | Attempt to guess the way the test suites in this package were compiled
 -- and linked with the library so the correct module interfaces are found.
@@ -141,58 +112,22 @@ guessWay lbi
   | withDynExe lbi = Dyn
   | otherwise = Vanilla
 
--- | Generate the HTML markup for a test suite.
-markupTest
-  :: Verbosity
-  -> LocalBuildInfo
-  -> FilePath
-  -- ^ \"dist/\" prefix
-  -> String
-  -- ^ Library name
-  -> TestSuite
-  -> Library
-  -> IO ()
-markupTest verbosity lbi distPref libraryName suite library = do
-  tixFileExists <- doesFileExist $ tixFilePath distPref way $ testName'
-  when tixFileExists $ do
-    -- behaviour of 'markup' depends on version, so we need *a* version
-    -- but no particular one
-    (hpc, hpcVer, _) <-
-      requireProgramVersion
-        verbosity
-        hpcProgram
-        anyVersion
-        (withPrograms lbi)
-    let htmlDir_ = htmlDir distPref way testName'
-    markup
-      hpc
-      hpcVer
-      verbosity
-      (tixFilePath distPref way testName')
-      mixDirs
-      htmlDir_
-      (exposedModules library)
-    notice verbosity $
-      "Test coverage report written to "
-        ++ htmlDir_
-        </> "hpc_index" <.> "html"
-  where
-    way = guessWay lbi
-    testName' = unUnqualComponentName $ testName suite
-    mixDirs = map (mixDir distPref way) [testName', libraryName]
-
--- | Generate the HTML markup for all of a package's test suites.
+-- | Generate the HTML markup for a package's test suites.
 markupPackage
   :: Verbosity
+  -> TestFlags
   -> LocalBuildInfo
   -> FilePath
-  -- ^ \"dist/\" prefix
+  -- ^ Testsuite \"dist/\" prefix
   -> PD.PackageDescription
   -> [TestSuite]
   -> IO ()
-markupPackage verbosity lbi distPref pkg_descr suites = do
-  let tixFiles = map (tixFilePath distPref way) testNames
+markupPackage verbosity TestFlags{testCoverageLibsDistPref, testCoverageLibsModules} lbi testDistPref pkg_descr suites = do
+  let tixFiles = map (tixFilePath testDistPref way) testNames
   tixFilesExist <- traverse doesFileExist tixFiles
+  putStrLn "ROMES: WRITING"
+  print testCoverageLibsDistPref
+  print testCoverageLibsModules
   when (and tixFilesExist) $ do
     -- behaviour of 'markup' depends on version, so we need *a* version
     -- but no particular one
@@ -202,19 +137,40 @@ markupPackage verbosity lbi distPref pkg_descr suites = do
         hpcProgram
         anyVersion
         (withPrograms lbi)
-    let outFile = tixFilePath distPref way libraryName
-        htmlDir' = htmlDir distPref way libraryName
-        excluded = concatMap testModules suites ++ [main]
-    createDirectoryIfMissing True $ takeDirectory outFile
-    union hpc verbosity tixFiles outFile excluded
-    markup hpc hpcVer verbosity outFile mixDirs htmlDir' included
+    let htmlDir' = htmlDir testDistPref way
+    -- The tix file used to generate the report is either the testsuite's
+    -- tix file, when there is only one testsuite, or the sum of the tix
+    -- files of all testsuites in the package, which gets put under pkgName
+    -- for this component (a bit weird)
+    -- TODO: cabal-install should pass to Cabal where to put the summed tix
+    -- and report, and perhaps even the testsuites from other packages in
+    -- the project which are currently not accounted for in the summed
+    -- report.
+    tixFile <- case suites of
+      -- We call 'markupPackage' once for each testsuite to run individually,
+      -- to get the coverage report of just the one testsuite
+      [oneTest] -> do
+        let testName' = unUnqualComponentName $ testName oneTest
+        return $
+          tixFilePath testDistPref way testName'
+      -- And call 'markupPackage' once per `test` invocation with all the
+      -- testsuites to run, which results in multiple tix files being considered
+      _         -> do
+        let excluded = concatMap testModules suites ++ [main]
+            pkgName = prettyShow $ PD.package pkg_descr
+            summedTixFile = tixFilePath testDistPref way pkgName
+        createDirectoryIfMissing True $ takeDirectory summedTixFile
+        union hpc verbosity tixFiles summedTixFile excluded
+        return summedTixFile
+          
+    markup hpc hpcVer verbosity tixFile mixDirs htmlDir' included
     notice verbosity $
       "Package coverage report written to "
         ++ htmlDir'
         </> "hpc_index.html"
   where
     way = guessWay lbi
     testNames = fmap (unUnqualComponentName . testName) suites
-    mixDirs = map (mixDir distPref way) $ libraryName : testNames
-    included = concatMap (exposedModules) $ PD.allLibraries pkg_descr
-    libraryName = prettyShow $ PD.package pkg_descr
+    mixDirs = mixDir testDistPref way : map (`mixDir` way) (fromFlagOrDefault [] testCoverageLibsDistPref)
+    included = fromFlagOrDefault [] testCoverageLibsModules
+

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

@@ -41,6 +41,7 @@ import Distribution.Verbosity
 import qualified Text.PrettyPrint as Disp
 
 import Distribution.Simple.Setup.Common
+import Distribution.ModuleName (ModuleName)
 
 -- ------------------------------------------------------------
 
@@ -88,6 +89,16 @@ 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.
+  , testCoverageLibsDistPref :: Flag [FilePath]
+  -- ^ The path to each main or sub library local to this project 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 library to cover.
+
   , -- TODO: think about if/how options are passed to test exes
     testOptions :: [PathTemplate]
   }
@@ -104,6 +115,8 @@ defaultTestFlags =
     , testKeepTix = toFlag False
     , testWrapper = NoFlag
     , testFailWhenNoTestSuites = toFlag False
+    , testCoverageLibsModules = NoFlag
+    , testCoverageLibsDistPref = NoFlag
     , testOptions = []
     }
 

Cabal/src/Distribution/Simple/Test.hs

@@ -133,7 +133,7 @@ test args pkg_descr lbi flags = do
   writeFile packageLogFile $ show packageLog
 
   when (LBI.testCoverage lbi) $
-    markupPackage verbosity lbi distPref pkg_descr $
+    markupPackage verbosity flags lbi distPref pkg_descr $
       map (fst . fst) testsToRun
 
   unless allOk exitFailure

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

@@ -10,7 +10,6 @@ import Prelude ()
 
 import Distribution.Compat.Environment
 import qualified Distribution.PackageDescription as PD
-import Distribution.Pretty
 import Distribution.Simple.Build.PathsModule
 import Distribution.Simple.BuildPaths
 import Distribution.Simple.Compiler
@@ -51,7 +50,7 @@ runTest
 runTest pkg_descr lbi clbi flags suite = do
   let isCoverageEnabled = LBI.testCoverage lbi
       way = guessWay lbi
-      tixDir_ = tixDir distPref way testName'
+      tixDir_ = tixDir distPref way
 
   pwd <- getCurrentDirectory
   existingEnv <- getEnvironment
@@ -171,11 +170,9 @@ runTest pkg_descr lbi clbi flags suite = do
   notice verbosity $ summarizeSuiteFinish suiteLog
 
   when isCoverageEnabled $
-    case PD.library pkg_descr of
-      Nothing ->
-        dieWithException verbosity TestCoverageSupport
-      Just library ->
-        markupTest verbosity lbi distPref (prettyShow $ PD.package pkg_descr) suite library
+    if null $ testCoverageLibsDistPref flags
+      then dieWithException verbosity TestCoverageSupport
+      else markupPackage verbosity flags lbi distPref pkg_descr [suite]
 
   return suiteLog
   where

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

@@ -80,12 +80,12 @@ runTest pkg_descr lbi clbi flags suite = do
 
   -- Remove old .tix files if appropriate.
   unless (fromFlag $ testKeepTix flags) $ do
-    let tDir = tixDir distPref way testName'
+    let tDir = tixDir distPref way
     exists' <- doesDirectoryExist tDir
     when exists' $ removeDirectoryRecursive tDir
 
   -- Create directory for HPC files.
-  createDirectoryIfMissing True $ tixDir distPref way testName'
+  createDirectoryIfMissing True $ tixDir distPref way
 
   -- Write summary notices indicating start of test suite
   notice verbosity $ summarizeSuiteStart testName'
@@ -186,11 +186,9 @@ runTest pkg_descr lbi clbi flags suite = do
   notice verbosity $ summarizeSuiteFinish suiteLog
 
   when isCoverageEnabled $
-    case PD.library pkg_descr of
-      Nothing ->
-        dieWithException verbosity TestCoverageSupportLibV09
-      Just library ->
-        markupTest verbosity lbi distPref (prettyShow $ PD.package pkg_descr) suite library
+    if null $ testCoverageLibsDistPref flags
+      then dieWithException verbosity TestCoverageSupportLibV09
+      else markupPackage verbosity flags lbi distPref pkg_descr [suite]
 
   return suiteLog
   where