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 haskell#5004 to fix haskell#4798.

- haskell#4798 was subsequently fixed "again" with the fix for haskell#5213, in haskell#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 haskell#7493 and instead determine
the `.mix` directories that are included in the call to `hpc markup` by
passing the list of components 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.

Multi-package project coverage is fixed in Cabal, however, the
paths to the source files listed in the `.mix` files will be incorrect
because package sources will no longer be in the root of the project
tree, but rather under the subdir with the package. We add an error for
multi-package projects when coverage is enabled, and track lifting this
error in haskell#9493.

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

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

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/Flag.hs

@@ -29,6 +29,7 @@ module Distribution.Simple.Flag
   , flagToMaybe
   , flagToList
   , maybeToFlag
+  , mergeListFlag
   , BooleanFlag (..)
   ) where
 
@@ -143,6 +144,12 @@ maybeToFlag :: Maybe a -> Flag a
 maybeToFlag Nothing = NoFlag
 maybeToFlag (Just x) = Flag x
 
+-- | Merge the elements of a list 'Flag' with another list 'Flag'.
+mergeListFlag :: Flag [a] -> Flag [a] -> Flag [a]
+mergeListFlag currentFlags v =
+  Flag $ concat (flagToList currentFlags ++ flagToList v)
+
+
 -- | Types that represent boolean flags.
 class BooleanFlag a where
   asBool :: a -> Bool

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

@@ -402,7 +402,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/GHC/BuildOrRepl.hs

@@ -7,7 +7,6 @@ import Control.Monad (forM_)
 import qualified Distribution.ModuleName as ModuleName
 import Distribution.Package
 import Distribution.PackageDescription as PD
-import Distribution.Pretty
 import Distribution.Simple.BuildPaths
 import Distribution.Simple.Compiler
 import Distribution.Simple.Flag (Flag (..), fromFlag, toFlag)
@@ -97,15 +96,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

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,57 +112,18 @@ 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{testCoverageDistPrefs, testCoverageLibsModules} lbi testDistPref pkg_descr suites = do
+  let tixFiles = map (tixFilePath testDistPref way) testNames
   tixFilesExist <- traverse doesFileExist tixFiles
   when (and tixFilesExist) $ do
     -- behaviour of 'markup' depends on version, so we need *a* version
@@ -202,19 +134,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 = map (`mixDir` way) (fromFlagOrDefault [] testCoverageDistPrefs)
+    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.
+  , 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]
   }
@@ -104,6 +115,8 @@ defaultTestFlags =
     , testKeepTix = toFlag False
     , testWrapper = NoFlag
     , testFailWhenNoTestSuites = toFlag False
+    , testCoverageLibsModules = NoFlag
+    , testCoverageDistPrefs = NoFlag
     , testOptions = []
     }
 
@@ -209,6 +222,36 @@ 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"]

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