[commit: Cabal] master: Generate aggregate coverage statistics from all test suites in package. (4e4c297)

[Ian Lynagh]

Repository : ssh://darcs.haskell.org//srv/darcs/packages/Cabal

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/4e4c2976decf52d808faab72ca2103c78c50ad2f

>---------------------------------------------------------------

commit 4e4c2976decf52d808faab72ca2103c78c50ad2f
Author: Thomas Tuegel <ttuegel at gmail.com>
Date:   Mon Jul 18 05:04:48 2011 +0000

    Generate aggregate coverage statistics from all test suites in package.

>---------------------------------------------------------------

 cabal/Distribution/Simple/Hpc.hs  |   52 +++++++++++++++++++++++++++++--------
 cabal/Distribution/Simple/Test.hs |   14 +++++++---
 2 files changed, 51 insertions(+), 15 deletions(-)

diff --git a/cabal/Distribution/Simple/Hpc.hs b/cabal/Distribution/Simple/Hpc.hs
index d6c4f3c..b579d16 100644
--- a/cabal/Distribution/Simple/Hpc.hs
+++ b/cabal/Distribution/Simple/Hpc.hs
@@ -42,8 +42,10 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
 
 module Distribution.Simple.Hpc
     ( enableCoverage
+    , htmlDir
     , tixDir
     , tixFilePath
+    , markupPackage
     , markupTest
     ) where
 
@@ -59,11 +61,11 @@ import Distribution.PackageDescription
     )
 import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) )
 import Distribution.Simple.Program ( hpcProgram, requireProgram )
-import Distribution.Simple.Program.Hpc ( markup )
+import Distribution.Simple.Program.Hpc ( markup, union )
 import Distribution.Simple.Utils ( notice )
 import Distribution.Text
 import Distribution.Verbosity ( Verbosity() )
-import System.Directory ( doesFileExist )
+import System.Directory ( createDirectoryIfMissing, doesFileExist )
 import System.FilePath
 
 -- -------------------------------------------------------------------------
@@ -111,15 +113,20 @@ mixDir :: FilePath  -- ^ \"dist/\" prefix
 mixDir distPref name = hpcDir distPref </> "mix" </> name
 
 tixDir :: FilePath  -- ^ \"dist/\" prefix
-       -> TestSuite -- ^ Test suite
+       -> FilePath  -- ^ Component name
        -> FilePath  -- ^ Directory containing test suite's .tix files
-tixDir distPref suite = hpcDir distPref </> "tix" </> testName suite
+tixDir distPref name = hpcDir distPref </> "tix" </> name
 
 -- | Path to the .tix file containing a test suite's sum statistics.
 tixFilePath :: FilePath     -- ^ \"dist/\" prefix
-            -> TestSuite    -- ^ Test suite
-            -> FilePath     -- Path to test suite's .tix file
-tixFilePath distPref suite = tixDir distPref suite </> testName suite <.> "tix"
+            -> FilePath     -- ^ Component name
+            -> FilePath     -- ^ Path to test suite's .tix file
+tixFilePath distPref name = tixDir distPref name </> name <.> "tix"
+
+htmlDir :: FilePath     -- ^ \"dist/\" prefix
+        -> FilePath     -- ^ Component name
+        -> FilePath     -- ^ Path to test suite's HTML markup directory
+htmlDir distPref name = hpcDir distPref </> "html" </> name
 
 -- | Generate the HTML markup for a test suite.
 markupTest :: Verbosity
@@ -129,12 +136,35 @@ markupTest :: Verbosity
            -> TestSuite
            -> IO ()
 markupTest verbosity lbi distPref libName suite = do
-    tixFileExists <- doesFileExist $ tixFilePath distPref suite
+    tixFileExists <- doesFileExist $ tixFilePath distPref $ testName suite
     when tixFileExists $ do
         (hpc, _) <- requireProgram verbosity hpcProgram $ withPrograms lbi
-        markup hpc verbosity (tixFilePath distPref suite)
+        markup hpc verbosity (tixFilePath distPref $ testName suite)
                              (mixDir distPref libName)
-                             (htmlDir distPref suite)
+                             (htmlDir distPref $ testName suite)
                              (testModules suite ++ [ main ])
         notice verbosity $ "Test coverage report written to "
-                            ++ htmlDir distPref suite </> "hpc_index" <.> "html"
+                            ++ htmlDir distPref (testName suite)
+                            </> "hpc_index" <.> "html"
+
+-- | Generate the HTML markup for all of a package's test suites.
+markupPackage :: Verbosity
+              -> LocalBuildInfo
+              -> FilePath       -- ^ \"dist/\" prefix
+              -> String         -- ^ Library name
+              -> [TestSuite]
+              -> IO ()
+markupPackage verbosity lbi distPref libName suites = do
+    let tixFiles = map (tixFilePath distPref . testName) suites
+    tixFilesExist <- mapM doesFileExist tixFiles
+    when (and tixFilesExist) $ do
+        (hpc, _) <- requireProgram verbosity hpcProgram $ withPrograms lbi
+        let outFile = tixFilePath distPref libName
+            mixDir' = mixDir distPref libName
+            htmlDir' = htmlDir distPref libName
+            excluded = concatMap testModules suites ++ [ main ]
+        createDirectoryIfMissing True $ takeDirectory outFile
+        union hpc verbosity tixFiles outFile excluded
+        markup hpc verbosity outFile mixDir' htmlDir' excluded
+        notice verbosity $ "Package coverage report written to "
+                           ++ htmlDir' </> "hpc_index.html"
diff --git a/cabal/Distribution/Simple/Test.hs b/cabal/Distribution/Simple/Test.hs
index bc62e80..3476e44 100644
--- a/cabal/Distribution/Simple/Test.hs
+++ b/cabal/Distribution/Simple/Test.hs
@@ -63,7 +63,8 @@ import qualified Distribution.PackageDescription as PD
 import Distribution.Simple.Build.PathsModule ( pkgPathEnvVar )
 import Distribution.Simple.BuildPaths ( exeExtension )
 import Distribution.Simple.Compiler ( Compiler(..), CompilerId )
-import Distribution.Simple.Hpc ( markupTest, tixDir, tixFilePath )
+import Distribution.Simple.Hpc
+    ( markupPackage, markupTest, tixDir, tixFilePath )
 import Distribution.Simple.InstallDirs
     ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..)
     , substPathTemplate , toPathTemplate, PathTemplate )
@@ -175,7 +176,8 @@ testController flags pkg_descr lbi suite preTest cmd postTest logNamer = do
     existingEnv <- getEnvironment
     let dataDirPath = pwd </> PD.dataDir pkg_descr
         shellEnv = Just $ (pkgPathEnvVar pkg_descr "datadir", dataDirPath)
-                        : ("HPCTIXFILE", pwd </> tixFilePath distPref suite)
+                        : ("HPCTIXFILE", (</>) pwd
+                            $ tixFilePath distPref $ PD.testName suite)
                         : existingEnv
 
     bracket (openCabalTemp testLogDir) deleteIfExists $ \tempLog ->
@@ -183,12 +185,12 @@ testController flags pkg_descr lbi suite preTest cmd postTest logNamer = do
 
             -- Remove old .tix files if appropriate.
             unless (fromFlag $ testKeepTix flags) $ do
-                let tDir = tixDir distPref suite
+                let tDir = tixDir distPref $ PD.testName suite
                 exists <- doesDirectoryExist tDir
                 when exists $ removeDirectoryRecursive tDir
 
             -- Create directory for HPC files.
-            createDirectoryIfMissing True $ tixDir distPref suite
+            createDirectoryIfMissing True $ tixDir distPref $ PD.testName suite
 
             -- Write summary notices indicating start of test suite
             notice verbosity $ summarizeSuiteStart $ PD.testName suite
@@ -347,6 +349,10 @@ test pkg_descr lbi flags = do
             $ packageLogPath machineTemplate pkg_descr lbi
     allOk <- summarizePackage verbosity packageLog
     writeFile packageLogFile $ show packageLog
+
+    markupPackage verbosity lbi distPref (display $ PD.package pkg_descr)
+        $ map fst testsToRun
+
     unless allOk exitFailure
 
 -- | Print a summary to the console after all test suites have been run