Fix test --enable-coverage for multi-package projects

ocharles · hololeap · commit f91e86bd014f · 2022-04-24T13:56:31.000-06:00
Currently, if you have multiple packages in a project and try and run the test suite of a single package with --enable-coverage, hpc will fail to run. The problem is that _all_ dependencies of the package are built with `-fhpc`, but when we run `hpc markup`, we are only passing the `.mix` directory of the package being tested. Because we built all dependencies with `-fhpc` and we haven't excluded them from the report, we need to supply their `.mix` directories too. The above suggests one fix - compute the transitive closure of all `.mix` directories. However, there is another solution - change from using an exclude-list to using an include-list. This is the approach used in this commit. Explicitly enumerating all modules to _include_ in the report is simpler to code, but is also more likely to be what the user is interested in. Generally, when one generates a coverage report from a test-suite, they want to understand the coverage of the unit being tested. Having coverage information from dependencies is usually not relevant. This is also the behavior from old-style Cabal builds, where there wasn't even a notion of a Cabal project. Fixes haskell#5433.
diff --git a/Cabal/src/Distribution/Simple/Hpc.hs b/Cabal/src/Distribution/Simple/Hpc.hs
@@ -29,10 +29,13 @@ import Distribution.Compat.Prelude
 
 import Distribution.Types.UnqualComponentName
 import Distribution.ModuleName ( main )
+import qualified Distribution.PackageDescription as PD
 import Distribution.PackageDescription
-    ( TestSuite(..)
+    ( Library(..)
+    , TestSuite(..)
     , testModules
     )
+import Distribution.Pretty
 import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) )
 import Distribution.Simple.Program
     ( hpcProgram
@@ -100,8 +103,9 @@ markupTest :: Verbosity
            -> FilePath     -- ^ \"dist/\" prefix
            -> String       -- ^ Library name
            -> TestSuite
+           -> Library
            -> IO ()
-markupTest verbosity lbi distPref libName suite = do
+markupTest verbosity lbi distPref libName suite library = do
     tixFileExists <- doesFileExist $ tixFilePath distPref way $ testName'
     when tixFileExists $ do
         -- behaviour of 'markup' depends on version, so we need *a* version
@@ -112,7 +116,7 @@ markupTest verbosity lbi distPref libName suite = do
         markup hpc hpcVer verbosity
             (tixFilePath distPref way testName') mixDirs
             htmlDir_
-            (testModules suite ++ [ main ])
+            (exposedModules library)
         notice verbosity $ "Test coverage report written to "
                             ++ htmlDir_ </> "hpc_index" <.> "html"
   where
@@ -124,10 +128,10 @@ markupTest verbosity lbi distPref libName suite = do
 markupPackage :: Verbosity
               -> LocalBuildInfo
               -> FilePath       -- ^ \"dist/\" prefix
-              -> String         -- ^ Library name
+              -> PD.PackageDescription
               -> [TestSuite]
               -> IO ()
-markupPackage verbosity lbi distPref libName suites = do
+markupPackage verbosity lbi distPref pkg_descr suites = do
     let tixFiles = map (tixFilePath distPref way) testNames
     tixFilesExist <- traverse doesFileExist tixFiles
     when (and tixFilesExist) $ do
@@ -140,10 +144,12 @@ markupPackage verbosity lbi distPref libName suites = do
             excluded = concatMap testModules suites ++ [ main ]
         createDirectoryIfMissing True $ takeDirectory outFile
         union hpc verbosity tixFiles outFile excluded
-        markup hpc hpcVer verbosity outFile mixDirs htmlDir' excluded
+        markup hpc hpcVer verbosity outFile 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) $ libName : testNames
+    included = concatMap (exposedModules) $ PD.allLibraries pkg_descr
+    libName = prettyShow $ PD.package pkg_descr
diff --git a/Cabal/src/Distribution/Simple/Program/Hpc.hs b/Cabal/src/Distribution/Simple/Program/Hpc.hs
@@ -42,9 +42,9 @@ markup :: ConfiguredProgram
        -> FilePath            -- ^ Path to .tix file
        -> [FilePath]          -- ^ Paths to .mix file directories
        -> FilePath            -- ^ Path where html output should be located
-       -> [ModuleName]        -- ^ List of modules to exclude from report
+       -> [ModuleName]        -- ^ List of modules to include in the report
        -> IO ()
-markup hpc hpcVer verbosity tixFile hpcDirs destDir excluded = do
+markup hpc hpcVer verbosity tixFile hpcDirs destDir included = do
     hpcDirs' <- if withinRange hpcVer (orLaterVersion version07)
         then return hpcDirs
         else do
@@ -63,7 +63,7 @@ markup hpc hpcVer verbosity tixFile hpcDirs destDir excluded = do
     hpcDirs'' <- traverse makeRelativeToCurrentDirectory hpcDirs'
 
     runProgramInvocation verbosity
-      (markupInvocation hpc tixFile hpcDirs'' destDir excluded)
+      (markupInvocation hpc tixFile hpcDirs'' destDir included)
   where
     version07 = mkVersion [0, 7]
     (passedDirs, droppedDirs) = splitAt 1 hpcDirs
@@ -73,16 +73,15 @@ markupInvocation :: ConfiguredProgram
                  -> [FilePath]          -- ^ Paths to .mix file directories
                  -> FilePath            -- ^ Path where html output should be
                                         -- located
-                 -> [ModuleName]        -- ^ List of modules to exclude from
-                                        -- report
+                 -> [ModuleName]        -- ^ List of modules to include
                  -> ProgramInvocation
-markupInvocation hpc tixFile hpcDirs destDir excluded =
+markupInvocation hpc tixFile hpcDirs destDir included =
     let args = [ "markup", tixFile
                , "--destdir=" ++ destDir
                ]
             ++ map ("--hpcdir=" ++) hpcDirs
-            ++ ["--exclude=" ++ prettyShow moduleName
-               | moduleName <- excluded ]
+            ++ ["--include=" ++ prettyShow moduleName
+               | moduleName <- included ]
     in programInvocation hpc args
 
 union :: ConfiguredProgram
diff --git a/Cabal/src/Distribution/Simple/Test.hs b/Cabal/src/Distribution/Simple/Test.hs
@@ -119,7 +119,7 @@ test args pkg_descr lbi flags = do
     writeFile packageLogFile $ show packageLog
 
     when (LBI.testCoverage lbi) $
-        markupPackage verbosity lbi distPref (prettyShow $ PD.package pkg_descr) $
+        markupPackage verbosity lbi distPref pkg_descr $
             map (fst . fst) testsToRun
 
     unless allOk exitFailure
diff --git a/Cabal/src/Distribution/Simple/Test/ExeV10.hs b/Cabal/src/Distribution/Simple/Test/ExeV10.hs
@@ -142,7 +142,12 @@ runTest pkg_descr lbi clbi flags suite = do
     notice verbosity $ summarizeSuiteFinish suiteLog
 
     when isCoverageEnabled $
-        markupTest verbosity lbi distPref (prettyShow $ PD.package pkg_descr) suite
+        case PD.library pkg_descr of
+            Nothing ->
+                die' verbosity $ "Error: test coverage is only supported for packages with a library component"
+
+            Just library ->
+                markupTest verbosity lbi distPref (prettyShow $ PD.package pkg_descr) suite library
 
     return suiteLog
   where
diff --git a/Cabal/src/Distribution/Simple/Test/LibV09.hs b/Cabal/src/Distribution/Simple/Test/LibV09.hs
@@ -158,7 +158,12 @@ runTest pkg_descr lbi clbi flags suite = do
     notice verbosity $ summarizeSuiteFinish suiteLog
 
     when isCoverageEnabled $
-        markupTest verbosity lbi distPref (prettyShow $ PD.package pkg_descr) suite
+        case PD.library pkg_descr of
+            Nothing ->
+                die' verbosity $ "Error: test coverage is only supported for packages with a library component"
+
+            Just library ->
+                markupTest verbosity lbi distPref (prettyShow $ PD.package pkg_descr) suite library
 
     return suiteLog
   where
