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