Commit f39f8242 authored by ttuegel's avatar ttuegel
Browse files

Invoke HPC using D.S.Program utilities.

This patch also reorganizes the HPC output directories for consistency. All
files related to HPC are now located in the "dist/hpc" directory.
parent 0d6cc119
......@@ -97,6 +97,7 @@ Library
Distribution.Simple.Program.Builtin,
Distribution.Simple.Program.Db,
Distribution.Simple.Program.HcPkg,
Distribution.Simple.Program.Hpc,
Distribution.Simple.Program.Ld,
Distribution.Simple.Program.Run,
Distribution.Simple.Program.Script,
......
......@@ -41,16 +41,13 @@ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
module Distribution.Simple.Hpc
( hpcDir
, enableCoverage
( enableCoverage
, tixDir
, tixFilePath
, doHpcMarkup
, findTixFiles
, markupTest
) where
import Control.Exception ( bracket )
import Control.Monad ( unless, when )
import Control.Monad ( when )
import Distribution.Compiler ( CompilerFlavor(..) )
import Distribution.ModuleName ( main )
import Distribution.PackageDescription
......@@ -60,14 +57,14 @@ import Distribution.PackageDescription
, TestSuite(..)
, testModules
)
import Distribution.Simple.Utils ( die, notice )
import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) )
import Distribution.Simple.Program ( hpcProgram, requireProgram )
import Distribution.Simple.Program.Hpc ( markup )
import Distribution.Simple.Utils ( notice )
import Distribution.Text
import Distribution.Verbosity ( Verbosity() )
import System.Directory ( doesFileExist, getDirectoryContents, removeFile )
import System.Exit ( ExitCode(..) )
import System.Directory ( doesFileExist )
import System.FilePath
import System.IO ( hClose, IOMode(..), openFile, openTempFile )
import System.Process ( runProcess, waitForProcess )
-- -------------------------------------------------------------------------
-- Haskell Program Coverage
......@@ -95,7 +92,7 @@ enableCoverage True distPref p =
Just xs -> (GHC, hpcOpts ++ xs)
_ -> (GHC, hpcOpts)
newOptions = (:) newGHCOpts $ filter ((== GHC) . fst) oldOptions
hpcOpts = ["-fhpc", "-hpcdir", hpcDir distPref name]
hpcOpts = ["-fhpc", "-hpcdir", mixDir distPref name]
in oldBI { options = newOptions }
enableLibCoverage l =
l { libBuildInfo = enableBICoverage (display $ package p)
......@@ -105,14 +102,18 @@ enableCoverage True distPref p =
t { testBuildInfo = enableBICoverage (testName t) (testBuildInfo t) }
hpcDir :: FilePath -- ^ \"dist/\" prefix
-> FilePath -- ^ Component subdirectory name
-> FilePath -- ^ Directory containing component's HPC .mix files
hpcDir distPref name = distPref </> "hpc" </> name
hpcDir distPref = distPref </> "hpc"
mixDir :: FilePath -- ^ \"dist/\" prefix
-> FilePath -- ^ Component name
-> FilePath -- ^ Directory containing test suite's .mix files
mixDir distPref name = hpcDir distPref </> "mix" </> name
tixDir :: FilePath -- ^ \"dist/\" prefix
-> TestSuite -- ^ Test suite
-> FilePath -- ^ Directory containing test suite's .tix files
tixDir distPref suite = distPref </> "test" </> testName suite
tixDir distPref suite = hpcDir distPref </> "tix" </> testName suite
-- | Path to the .tix file containing a test suite's sum statistics.
tixFilePath :: FilePath -- ^ \"dist/\" prefix
......@@ -120,66 +121,20 @@ tixFilePath :: FilePath -- ^ \"dist/\" prefix
-> FilePath -- Path to test suite's .tix file
tixFilePath distPref suite = tixDir distPref suite </> testName suite <.> "tix"
-- | Returns a list of all the .tix files in a test suite's .tix file
-- directory. Returned paths are the complete relative path to each file.
findTixFiles :: FilePath -- ^ \"dist/\" prefix
-> TestSuite -- ^ Test suite
-> IO [FilePath] -- ^ All .tix files belonging to test suite
findTixFiles distPref suite = do
files <- getDirectoryContents $ tixDir distPref suite
let tixFiles = flip filter files $ \x -> takeExtension x == ".tix"
return $ map (tixDir distPref suite </>) tixFiles
-- | Generate the HTML markup for a test suite.
doHpcMarkup :: Verbosity
-> FilePath -- ^ \"dist/\" prefix
-> String -- ^ Library name
-> TestSuite
-> IO ()
doHpcMarkup verbosity distPref libName suite = do
tixFiles <- findTixFiles distPref suite
when (not $ null tixFiles) $ do
let hpcOptions = map (\x -> "--exclude=" ++ display x) excluded
unionOptions = [ "sum"
, "--union"
, "--output=" ++ tixFilePath distPref suite
]
++ hpcOptions ++ tixFiles
markupOptions = [ "markup"
, tixFilePath distPref suite
, "--hpcdir=" ++ hpcDir distPref libName
, "--destdir=" ++ tixDir distPref suite
]
++ hpcOptions
excluded = testModules suite ++ [ main ]
--TODO: use standard process utilities from D.S.Utils
runHpc opts h = runProcess "hpc" opts Nothing Nothing Nothing
(Just h) (Just h)
bracket (openHpcTemp $ tixDir distPref suite) deleteIfExists
$ \hpcOut -> do
hUnion <- openFile hpcOut AppendMode
procUnion <- runHpc unionOptions hUnion
exitUnion <- waitForProcess procUnion
success <- case exitUnion of
ExitSuccess -> do
hMarkup <- openFile hpcOut AppendMode
procMarkup <- runHpc markupOptions hMarkup
exitMarkup <- waitForProcess procMarkup
case exitMarkup of
ExitSuccess -> return True
_ -> return False
_ -> return False
unless success $ do
errs <- readFile hpcOut
die $ "HPC failed:\n" ++ errs
when success $ notice verbosity
$ "Test coverage report written to "
++ tixDir distPref suite </> "hpc_index"
<.> "html"
return ()
where openHpcTemp dir = do
(f, h) <- openTempFile dir $ "cabal-test-hpc-" <.> "log"
hClose h >> return f
deleteIfExists path = do
exists <- doesFileExist path
when exists $ removeFile path
markupTest :: Verbosity
-> LocalBuildInfo
-> FilePath -- ^ \"dist/\" prefix
-> String -- ^ Library name
-> TestSuite
-> IO ()
markupTest verbosity lbi distPref libName suite = do
tixFileExists <- doesFileExist $ tixFilePath distPref suite
when tixFileExists $ do
(hpc, _) <- requireProgram verbosity hpcProgram $ withPrograms lbi
markup hpc verbosity (tixFilePath distPref suite)
(mixDir distPref libName)
(htmlDir distPref suite)
(testModules suite ++ [ main ])
notice verbosity $ "Test coverage report written to "
++ htmlDir distPref suite </> "hpc_index" <.> "html"
......@@ -110,6 +110,7 @@ module Distribution.Simple.Program (
, tarProgram
, cppProgram
, pkgConfigProgram
, hpcProgram
-- * deprecated
, rawSystemProgram
......
......@@ -42,6 +42,7 @@ module Distribution.Simple.Program.Builtin (
tarProgram,
cppProgram,
pkgConfigProgram,
hpcProgram,
) where
import Distribution.Simple.Program.Types
......@@ -69,6 +70,7 @@ builtinPrograms =
, lhcProgram
, lhcPkgProgram
, uhcProgram
, hpcProgram
-- preprocessors
, hscolourProgram
, haddockProgram
......@@ -155,6 +157,14 @@ uhcProgram = (simpleProgram "uhc") {
programFindVersion = findProgramVersion "--version-dotted" id
}
hpcProgram :: Program
hpcProgram = (simpleProgram "hpc")
{
programFindVersion = findProgramVersion "version" $ \str ->
case words str of
(_ : _ : _ : ver : _) -> ver
_ -> ""
}
-- AArgh! Finding the version of hugs or ffihugs is almost impossible.
hugsProgram :: Program
......
......@@ -63,7 +63,7 @@ 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 ( doHpcMarkup, findTixFiles, tixDir )
import Distribution.Simple.Hpc ( markupTest, tixDir, tixFilePath )
import Distribution.Simple.InstallDirs
( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..)
, substPathTemplate , toPathTemplate, PathTemplate )
......@@ -82,8 +82,9 @@ import Control.Monad ( when, liftM, unless, filterM )
import Data.Char ( toUpper )
import Data.Monoid ( mempty )
import System.Directory
( createDirectoryIfMissing, doesFileExist, getCurrentDirectory
, removeFile, getDirectoryContents )
( createDirectoryIfMissing, doesDirectoryExist, doesFileExist
, getCurrentDirectory, getDirectoryContents, removeDirectoryRecursive
, removeFile )
import System.Environment ( getEnvironment )
import System.Exit ( ExitCode(..), exitFailure, exitWith )
import System.FilePath ( (</>), (<.>) )
......@@ -174,26 +175,22 @@ 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)
: ("HPCTIXDIR", pwd </> tixDir distPref suite)
: ("HPCTIXFILE", pwd </> tixFilePath distPref suite)
: existingEnv
bracket (openCabalTemp testLogDir) deleteIfExists $ \tempLog ->
bracket (openCabalTemp testLogDir) deleteIfExists $ \tempInput -> do
-- Check that the test executable exists.
exists <- doesFileExist cmd
unless exists $ die $ "Error: Could not find test program \"" ++ cmd
++ "\". Did you build the package first?"
-- Remove old .tix files if appropriate.
unless (fromFlag $ testKeepTix flags) $ do
let tDir = tixDir distPref suite
exists <- doesDirectoryExist tDir
when exists $ removeDirectoryRecursive tDir
-- Create directory for HPC files.
createDirectoryIfMissing True $ tixDir distPref suite
-- Remove old .tix files if appropriate.
tixFiles <- findTixFiles distPref suite
unless (fromFlag $ testKeepTix flags)
$ mapM_ deleteIfExists tixFiles
-- Write summary notice to console indicating start of test suite
-- Write summary notices indicating start of test suite
notice verbosity $ summarizeSuiteStart $ PD.testName suite
-- Prepare standard input for test executable
......@@ -238,7 +235,8 @@ testController flags pkg_descr lbi suite preTest cmd postTest logNamer = do
-- Write summary notice to terminal indicating end of test suite
notice verbosity $ summarizeSuiteFinish suiteLog'
doHpcMarkup verbosity distPref (display $ PD.package pkg_descr) suite
markupTest verbosity lbi distPref
(display $ PD.package pkg_descr) suite
return suiteLog'
where
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment