Allow per-component 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.

However, the fix for haskell#5213, in haskell#7493, fixes the paths of the testsuite
`.mix` files to the same location as that of the main library component,
which in turn fixes haskell#4798 as well -- meaning the restriction to treat
testsuites per-package (legacy-fallback) is no longer needed.

1. We allow hpc in per-component builds

2. To generate hpc files in the appropriate component directories in the
distribution tree, we move the hack from haskell#7493 from dictating the `.mix`
directories where hpc information is stored to dictating the `.mix`
directories that are included in the call to `hpc markup`. We also drop
an unnecessary directory in the hpc file hierarchy.

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

4. We only add non-indefinite libraries to the hpc markup command.
    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

The combination of (1,3) fix haskell#6440, and adding (4) fixes haskell#6397

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

Fixes haskell#6440, haskell#6397, and fixes in a new way the previously fixed haskell#4798, haskell#5213.

Cabal/src/Distribution/Simple/GHC.hs

@@ -651,7 +651,7 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do
  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 +1548,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

@@ -523,7 +523,7 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do
  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 +1243,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

@@ -48,6 +48,8 @@ import Distribution.Verbosity (Verbosity ())
 import Distribution.Version (anyVersion)
 import System.Directory (createDirectoryIfMissing, doesFileExist)
 import System.FilePath
+import Distribution.Types.LocalBuildInfo (componentNameCLBIs)
+import Distribution.Types.ComponentLocalBuildInfo (componentIsIndefinite)
 
 -- -------------------------------------------------------------------------
 -- Haskell Program Coverage
@@ -73,44 +75,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 +95,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.
@@ -146,14 +118,12 @@ markupTest
  :: Verbosity
  -> LocalBuildInfo
  -> FilePath
- -- ^ \"dist/\" prefix
- -> String
- -- ^ Library name
+ -- ^ Testsuite \"dist/\" prefix
+ -> PD.PackageDescription
  -> TestSuite
- -> Library
  -> IO ()
-markupTest verbosity lbi distPref libraryName suite library = do
- tixFileExists <- doesFileExist $ tixFilePath distPref way $ testName'
+markupTest verbosity lbi testDistPref pkg_descr suite = do
+ tixFileExists <- doesFileExist $ tixFilePath testDistPref way $ testName'
  when tixFileExists $ do
  -- behaviour of 'markup' depends on version, so we need *a* version
  -- but no particular one
@@ -163,35 +133,36 @@ markupTest verbosity lbi distPref libraryName suite library = do
  hpcProgram
  anyVersion
  (withPrograms lbi)
- let htmlDir_ = htmlDir distPref way testName'
+ let htmlDir_ = htmlDir testDistPref way
  markup
  hpc
  hpcVer
  verbosity
- (tixFilePath distPref way testName')
+ (tixFilePath testDistPref way testName')
  mixDirs
  htmlDir_
- (exposedModules library)
+ included
  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]
+ mixDirs = mixDir testDistPref way : map (libMixDir way testDistPref) (nonIndefiniteLibraries lbi pkg_descr)
+ included = concatMap exposedModules $ nonIndefiniteLibraries lbi pkg_descr
 
 -- | Generate the HTML markup for all of a package's test suites.
 markupPackage
  :: Verbosity
  -> 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 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,8 +173,8 @@ markupPackage verbosity lbi distPref pkg_descr suites = do
  hpcProgram
  anyVersion
  (withPrograms lbi)
- let outFile = tixFilePath distPref way libraryName
- htmlDir' = htmlDir distPref way libraryName
+ let outFile = tixFilePath testDistPref way pkgName
+ htmlDir' = htmlDir testDistPref way
  excluded = concatMap testModules suites ++ [main]
  createDirectoryIfMissing True $ takeDirectory outFile
  union hpc verbosity tixFiles outFile excluded
@@ -215,6 +186,75 @@ markupPackage verbosity lbi distPref pkg_descr suites = do
  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
+ pkgName = prettyShow $ PD.package pkg_descr
+ mixDirs = mixDir testDistPref way : map (libMixDir way testDistPref) (nonIndefiniteLibraries lbi pkg_descr)
+ included = concatMap exposedModules $ nonIndefiniteLibraries lbi pkg_descr
+
+-- | Get all the non-indefinite libraries in a package, ignoring indefinite
+-- components and their instantiations.
+-- HPC doesn't support backpack (eg. would does it mean to cover a module of a
+-- library that is instantiated in two different ways?), so we invoke this
+-- function to determine which library hpc dirs to add to the include path of
+-- the hpc markup command.
+nonIndefiniteLibraries :: LocalBuildInfo -> PD.PackageDescription -> [Library]
+nonIndefiniteLibraries lbi pkg_desc
+ = [ lib
+ | lib <- PD.allLibraries pkg_desc
+ -- We only care about libraries with exactly one CLBI.
+ -- If there were more than one CLBI, they would be the indefinite CLBI and
+ -- the multiple instantiations.
+ -- Because backpack is unsupported by hpc, we ignore all indefinite components
+ , [c] <- pure $ componentNameCLBIs lbi (PD.CLibName (libName lib))
+ , not $ componentIsIndefinite c
+ ]
+
+-- | Determine the path to the library's `.mix` dir for the given way
+libMixDir :: Way
+ -> FilePath
+ -- ^ Testsuite dist-dir prefix (needed in the pathToLibHpc hack)
+ -> Library
+ -> FilePath
+libMixDir way testDistPref lib = pathToLibHpc testDistPref (PD.libName lib) `mixDir` way
+
+
+-- | A (non-exported) hack to determine the path to the main and internal libs
+-- directory given the testsuite's dist prefix.
+--
+-- We use this function when constructing calls to `hpc markup` since otherwise
+-- having cabal-install communicate the path to the main and sub libraries
+-- dist-dir when building the test component, via the Setup.hs interface, is
+-- far more complicated.
+pathToLibHpc :: FilePath -> PD.LibraryName -> FilePath
+pathToLibHpc testDistPref libname = distPrefLib
+ 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 testDistPref
+ distPrefLib = case drop (length distPrefElements - 3) distPrefElements of
+ ["t", _, "noopt"] ->
+ joinPath $
+ take (length distPrefElements - 3) distPrefElements
+ ++ [distSuffixInternalLib]
+ ++ ["noopt"]
+ ["t", _, "opt"] ->
+ joinPath $
+ take (length distPrefElements - 3) distPrefElements
+ ++ [distSuffixInternalLib]
+ ++ ["opt"]
+ [_, "t", _] ->
+ joinPath $
+ take (length distPrefElements - 2) distPrefElements
+ ++ [distSuffixInternalLib]
+ _ -> error "pathToLibHpc: Expecting `testDirPref` to be the dist prefix of a test-suite component"
+ distSuffixInternalLib = case libname of
+ PD.LMainLibName -> ""
+ PD.LSubLibName slname -> "l" </> unUnqualComponentName slname
+

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
@@ -174,8 +173,8 @@ runTest pkg_descr lbi clbi flags suite = do
  case PD.library pkg_descr of
  Nothing ->
  dieWithException verbosity TestCoverageSupport
- Just library ->
- markupTest verbosity lbi distPref (prettyShow $ PD.package pkg_descr) suite library
+ Just _library ->
+ markupTest verbosity 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'
@@ -189,8 +189,8 @@ runTest pkg_descr lbi clbi flags suite = do
  case PD.library pkg_descr of
  Nothing ->
  dieWithException verbosity TestCoverageSupportLibV09
- Just library ->
- markupTest verbosity lbi distPref (prettyShow $ PD.package pkg_descr) suite library
+ Just _library ->
+ markupTest verbosity lbi distPref pkg_descr suite
 
  return suiteLog
  where

Cabal/src/Distribution/Types/LocalBuildInfo.hs

@@ -108,6 +108,7 @@ data LocalBuildInfo = LocalBuildInfo
  , componentNameMap :: Map ComponentName [ComponentLocalBuildInfo]
  -- ^ A map from component name to all matching
  -- components. These coincide with 'componentGraph'
+ -- There may be more than one matching component because of backpack instantiations
  , promisedPkgs :: Map (PackageName, ComponentName) ComponentId
  -- ^ The packages we were promised, but aren't already installed.
  -- MP: Perhaps this just needs to be a Set UnitId at this stage.

cabal-install/src/Distribution/Client/ProjectPlanning.hs

@@ -1673,7 +1673,7 @@ elaborateInstallPlan
  where
  -- You are eligible to per-component build if this list is empty
  why_not_per_component g =
- cuz_buildtype ++ cuz_spec ++ cuz_length ++ cuz_flag ++ cuz_coverage
+ cuz_buildtype ++ cuz_spec ++ cuz_length ++ cuz_flag
  where
  cuz reason = [text reason]
  -- We have to disable per-component for now with
@@ -1710,12 +1710,6 @@ elaborateInstallPlan
  | fromFlagOrDefault True (projectConfigPerComponent sharedPackageConfig) =
  []
  | otherwise = cuz "you passed --disable-per-component"
- -- Enabling program coverage introduces odd runtime dependencies
- -- between components.
- cuz_coverage
- | fromFlagOrDefault False (packageConfigCoverage localPackagesConfig) =
- cuz "program coverage is enabled"
- | otherwise = []
 
  -- \| Sometimes a package may make use of features which are only
  -- supported in per-package mode. If this is the case, we should

cabal-testsuite/PackageTests/Backpack/Includes2/Includes2.cabal

@@ -39,3 +39,10 @@ executable exe
  main-is: Main.hs
  hs-source-dirs: exe
  default-language: Haskell2010
+
+test-suite test
+ type: exitcode-stdio-1.0
+ build-depends: base, Includes2
+ main-is: test.hs
+ hs-source-dirs: test
+ default-language: Haskell2010

cabal-testsuite/PackageTests/Backpack/Includes2/enable-coverage.test.hs

@@ -0,0 +1,4 @@
+import Test.Cabal.Prelude
+main = cabalTest $ do
+ skipUnlessGhcVersion ">= 8.1"
+ cabal "test" ["--enable-coverage"]

cabal-testsuite/PackageTests/Regression/T4798/T4798.cabal

@@ -0,0 +1,18 @@
+cabal-version: 3.0
+name: T4798
+version: 0.1
+
+library
+ exposed-modules: U2F, U2F.Types
+ ghc-options: -Wall
+ build-depends: base
+ hs-source-dirs: src
+ default-language: Haskell2010
+
+test-suite hspec-suite
+ type: exitcode-stdio-1.0
+ main-is: test.hs
+ ghc-options: -Wall
+ hs-source-dirs: tests
+ default-language: Haskell2010
+ build-depends: base, T4798

cabal-testsuite/PackageTests/Regression/T4798/cabal.project

@@ -0,0 +1 @@
+packages: .

cabal-testsuite/PackageTests/Regression/T4798/cabal.test.hs

@@ -0,0 +1,3 @@
+import Test.Cabal.Prelude
+main = cabalTest $ cabal "test" ["--enable-coverage"]
+

cabal-testsuite/PackageTests/Regression/T4798/src/U2F.hs

@@ -0,0 +1,6 @@
+module U2F where
+
+import U2F.Types
+
+ourCurve :: String
+ourCurve = show SEC_p256r1