stack-2.9.3: src/Stack/Coverage.hs
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
-- | Generate HPC (Haskell Program Coverage) reports
module Stack.Coverage
( deleteHpcReports
, updateTixFile
, generateHpcReport
, HpcReportOpts (..)
, generateHpcReportForTargets
, generateHpcUnifiedReport
, generateHpcMarkupIndex
) where
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as BL
import qualified Data.List as L
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import Distribution.Version ( mkVersion )
import Path
import Path.Extra ( toFilePathNoTrailingSep )
import Path.IO
import RIO.Process
import Stack.Build.Target
import Stack.Constants
import Stack.Constants.Config
import Stack.Package
import Stack.Prelude
import Stack.Types.Compiler
import Stack.Types.Config
import Stack.Types.NamedComponent
import Stack.Types.Package
import Stack.Types.SourceMap
import System.FilePath ( isPathSeparator )
import Trace.Hpc.Tix
import Web.Browser (openBrowser)
-- | Type representing exceptions thrown by functions exported by the
-- "Stack.Coverage" module.
data CoverageException
= NonTestSuiteTarget PackageName
| NoTargetsOrTixSpecified
| NotLocalPackage PackageName
deriving (Show, Typeable)
instance Exception CoverageException where
displayException (NonTestSuiteTarget name) = concat
[ "Error: [S-6361]\n"
, "Can't specify anything except test-suites as hpc report targets ("
, packageNameString name
, ") is used with a non test-suite target."
]
displayException NoTargetsOrTixSpecified =
"Error: [S-2321]\n"
++ "Not generating combined report, because no targets or tix files \
\are specified."
displayException (NotLocalPackage name) = concat
[ "Error: [S-9975]"
, "Expected a local package, but "
, packageNameString name
, " is either an extra-dep or in the snapshot."
]
-- | Invoked at the beginning of running with "--coverage"
deleteHpcReports :: HasEnvConfig env => RIO env ()
deleteHpcReports = do
hpcDir <- hpcReportDir
liftIO $ ignoringAbsence (removeDirRecur hpcDir)
-- | Move a tix file into a sub-directory of the hpc report directory. Deletes
-- the old one if one is present.
updateTixFile ::
HasEnvConfig env
=> PackageName
-> Path Abs File
-> String
-> RIO env ()
updateTixFile pkgName' tixSrc testName = do
exists <- doesFileExist tixSrc
when exists $ do
tixDest <- tixFilePath pkgName' testName
liftIO $ ignoringAbsence (removeFile tixDest)
ensureDir (parent tixDest)
-- Remove exe modules because they are problematic. This could be
-- revisited if there's a GHC version that fixes
-- https://ghc.haskell.org/trac/ghc/ticket/1853
mtix <- readTixOrLog tixSrc
case mtix of
Nothing -> logError $
"Error: [S-2887]\n" <>
"Failed to read " <>
fromString (toFilePath tixSrc)
Just tix -> do
liftIO $ writeTix (toFilePath tixDest) (removeExeModules tix)
-- TODO: ideally we'd do a file move, but IIRC this can
-- have problems. Something about moving between drives
-- on windows?
copyFile tixSrc =<< parseAbsFile (toFilePath tixDest ++ ".premunging")
liftIO $ ignoringAbsence (removeFile tixSrc)
-- | Get the directory used for hpc reports for the given pkgId.
hpcPkgPath :: HasEnvConfig env => PackageName -> RIO env (Path Abs Dir)
hpcPkgPath pkgName' = do
outputDir <- hpcReportDir
pkgNameRel <- parseRelDir (packageNameString pkgName')
pure (outputDir </> pkgNameRel)
-- | Get the tix file location, given the name of the file (without extension),
-- and the package identifier string.
tixFilePath :: HasEnvConfig env
=> PackageName -> String -> RIO env (Path Abs File)
tixFilePath pkgName' testName = do
pkgPath <- hpcPkgPath pkgName'
tixRel <- parseRelFile (testName ++ "/" ++ testName ++ ".tix")
pure (pkgPath </> tixRel)
-- | Generates the HTML coverage report and shows a textual coverage summary for a package.
generateHpcReport :: HasEnvConfig env
=> Path Abs Dir -> Package -> [Text] -> RIO env ()
generateHpcReport pkgDir package tests = do
compilerVersion <- view actualCompilerVersionL
-- If we're using > GHC 7.10, the hpc 'include' parameter must specify a ghc package key. See
-- https://github.com/commercialhaskell/stack/issues/785
let pkgName' = T.pack $ packageNameString (packageName package)
pkgId = packageIdentifierString (packageIdentifier package)
ghcVersion = getGhcVersion compilerVersion
hasLibrary =
case packageLibraries package of
NoLibraries -> False
HasLibraries _ -> True
internalLibs = packageInternalLibraries package
eincludeName <-
-- Pre-7.8 uses plain PKG-version in tix files.
if ghcVersion < mkVersion [7, 10] then pure $ Right $ Just [pkgId]
-- We don't expect to find a package key if there is no library.
else if not hasLibrary && Set.null internalLibs then pure $ Right Nothing
-- Look in the inplace DB for the package key.
-- See https://github.com/commercialhaskell/stack/issues/1181#issuecomment-148968986
else do
-- GHC 8.0 uses package id instead of package key.
-- See https://github.com/commercialhaskell/stack/issues/2424
let hpcNameField = if ghcVersion >= mkVersion [8, 0] then "id" else "key"
eincludeName <- findPackageFieldForBuiltPackage pkgDir (packageIdentifier package) internalLibs hpcNameField
case eincludeName of
Left err -> do
logError $ display err
pure $ Left err
Right includeNames -> pure $ Right $ Just $ map T.unpack includeNames
forM_ tests $ \testName -> do
tixSrc <- tixFilePath (packageName package) (T.unpack testName)
let report = "coverage report for " <> pkgName' <> "'s test-suite \"" <> testName <> "\""
reportDir = parent tixSrc
case eincludeName of
Left err -> generateHpcErrorReport reportDir (display (sanitize (T.unpack err)))
-- Restrict to just the current library code, if there is a library in the package (see
-- #634 - this will likely be customizable in the future)
Right mincludeName -> do
let extraArgs = case mincludeName of
Nothing -> []
Just includeNames ->
"--include" : L.intersperse "--include" (map (\n -> n ++ ":") includeNames)
mreportPath <- generateHpcReportInternal tixSrc reportDir report extraArgs extraArgs
forM_ mreportPath (displayReportPath "The" report . pretty)
generateHpcReportInternal :: HasEnvConfig env
=> Path Abs File -> Path Abs Dir -> Text -> [String] -> [String]
-> RIO env (Maybe (Path Abs File))
generateHpcReportInternal tixSrc reportDir report extraMarkupArgs extraReportArgs = do
-- If a .tix file exists, move it to the HPC output directory and generate a
-- report for it.
tixFileExists <- doesFileExist tixSrc
if not tixFileExists
then do
logError $
"Error: [S-4634]\n" <>
"Didn't find .tix for " <>
display report <>
" - expected to find it at " <>
fromString (toFilePath tixSrc) <>
"."
pure Nothing
else (`catch` \(err :: ProcessException) -> do
logError $ displayShow err
generateHpcErrorReport reportDir $ display $ sanitize $
displayException err
pure Nothing) $
(`onException`
logError
("Error: [S-8215]\n" <>
"Error occurred while producing " <>
display report)) $ do
-- Directories for .mix files.
hpcRelDir <- hpcRelativeDir
-- Compute arguments used for both "hpc markup" and "hpc report".
pkgDirs <- view $ buildConfigL.to (map ppRoot . Map.elems . smwProject . bcSMWanted)
let args =
-- Use index files from all packages (allows cross-package coverage results).
concatMap (\x -> ["--srcdir", toFilePathNoTrailingSep x]) pkgDirs ++
-- Look for index files in the correct dir (relative to each pkgdir).
["--hpcdir", toFilePathNoTrailingSep hpcRelDir, "--reset-hpcdirs"]
logInfo $ "Generating " <> display report
outputLines <- liftM (map (S8.filter (/= '\r')) . S8.lines . BL.toStrict . fst) $
proc "hpc"
( "report"
: toFilePath tixSrc
: (args ++ extraReportArgs)
)
readProcess_
if all ("(0/0)" `S8.isSuffixOf`) outputLines
then do
let msg html =
"Error: [S-6829]\n"<>
"The " <>
display report <>
" did not consider any code. One possible cause of this is" <>
" if your test-suite builds the library code (see Stack " <>
(if html then "<a href='https://github.com/commercialhaskell/stack/issues/1008'>" else "") <>
"issue #1008" <>
(if html then "</a>" else "") <>
"). It may also indicate a bug in Stack or" <>
" the hpc program. Please report this issue if you think" <>
" your coverage report should have meaningful results."
logError (msg False)
generateHpcErrorReport reportDir (msg True)
pure Nothing
else do
let reportPath = reportDir </> relFileHpcIndexHtml
-- Print output, stripping @\r@ characters because Windows.
forM_ outputLines (logInfo . displayBytesUtf8)
-- Generate the markup.
void $ proc "hpc"
( "markup"
: toFilePath tixSrc
: ("--destdir=" ++ toFilePathNoTrailingSep reportDir)
: (args ++ extraMarkupArgs)
)
readProcess_
pure (Just reportPath)
data HpcReportOpts = HpcReportOpts
{ hroptsInputs :: [Text]
, hroptsAll :: Bool
, hroptsDestDir :: Maybe String
, hroptsOpenBrowser :: Bool
} deriving (Show)
generateHpcReportForTargets :: HasEnvConfig env
=> HpcReportOpts -> [Text] -> [Text] -> RIO env ()
generateHpcReportForTargets opts tixFiles targetNames = do
targetTixFiles <-
-- When there aren't any package component arguments, and --all
-- isn't passed, default to not considering any targets.
if not (hroptsAll opts) && null targetNames
then pure []
else do
when (hroptsAll opts && not (null targetNames)) $
logWarn $ "Since --all is used, it is redundant to specify these targets: " <> displayShow targetNames
targets <- view $ envConfigL.to envConfigSourceMap.to smTargets.to smtTargets
liftM concat $ forM (Map.toList targets) $ \(name, target) ->
case target of
TargetAll PTDependency -> throwIO $ NotLocalPackage name
TargetComps comps -> do
pkgPath <- hpcPkgPath name
forM (toList comps) $ \nc ->
case nc of
CTest testName ->
liftM (pkgPath </>) $ parseRelFile (T.unpack testName ++ "/" ++ T.unpack testName ++ ".tix")
_ -> throwIO $ NonTestSuiteTarget name
TargetAll PTProject -> do
pkgPath <- hpcPkgPath name
exists <- doesDirExist pkgPath
if exists
then do
(dirs, _) <- listDir pkgPath
liftM concat $ forM dirs $ \dir -> do
(_, files) <- listDir dir
pure (filter ((".tix" `L.isSuffixOf`) . toFilePath) files)
else pure []
tixPaths <- liftM (\xs -> xs ++ targetTixFiles) $ mapM (resolveFile' . T.unpack) tixFiles
when (null tixPaths) $ throwIO NoTargetsOrTixSpecified
outputDir <- hpcReportDir
reportDir <- case hroptsDestDir opts of
Nothing -> pure (outputDir </> relDirCombined </> relDirCustom)
Just destDir -> do
dest <- resolveDir' destDir
ensureDir dest
pure dest
let report = "combined report"
mreportPath <- generateUnionReport report reportDir tixPaths
forM_ mreportPath $ \reportPath ->
if hroptsOpenBrowser opts
then do
prettyInfo $ "Opening" <+> pretty reportPath <+> "in the browser."
void $ liftIO $ openBrowser (toFilePath reportPath)
else displayReportPath "The" report (pretty reportPath)
generateHpcUnifiedReport :: HasEnvConfig env => RIO env ()
generateHpcUnifiedReport = do
outputDir <- hpcReportDir
ensureDir outputDir
(dirs, _) <- listDir outputDir
tixFiles0 <- liftM (concat . concat) $ forM (filter (("combined" /=) . dirnameString) dirs) $ \dir -> do
(dirs', _) <- listDir dir
forM dirs' $ \dir' -> do
(_, files) <- listDir dir'
pure (filter ((".tix" `L.isSuffixOf`) . toFilePath) files)
extraTixFiles <- findExtraTixFiles
let tixFiles = tixFiles0 ++ extraTixFiles
reportDir = outputDir </> relDirCombined </> relDirAll
-- Previously, the test below was:
--
-- if length tixFiles < 2
-- then logInfo $
-- (if null tixFiles then "No tix files" else "Only one tix file") <>
-- " found in " <>
-- fromString (toFilePath outputDir) <>
-- ", so not generating a unified coverage report."
-- else ...
--
-- However, a single *.tix file does not necessarily mean that a unified
-- coverage report is redundant. For example, one package may test the library
-- of another package that does not test its own library. See
-- https://github.com/commercialhaskell/stack/issues/5713
--
-- As an interim solution, a unified coverage report will always be produced
-- even if may be redundant in some circumstances.
if null tixFiles
then logInfo $ "No tix files found in " <>
fromString (toFilePath outputDir) <>
", so not generating a unified coverage report."
else do
let report = "unified report"
mreportPath <- generateUnionReport report reportDir tixFiles
forM_ mreportPath (displayReportPath "The" report . pretty)
generateUnionReport :: HasEnvConfig env
=> Text -> Path Abs Dir -> [Path Abs File]
-> RIO env (Maybe (Path Abs File))
generateUnionReport report reportDir tixFiles = do
(errs, tix) <- fmap (unionTixes . map removeExeModules) (mapMaybeM readTixOrLog tixFiles)
logDebug $ "Using the following tix files: " <> fromString (show tixFiles)
unless (null errs) $ logWarn $
"The following modules are left out of the " <>
display report <>
" due to version mismatches: " <>
mconcat (L.intersperse ", " (map fromString errs))
tixDest <- liftM (reportDir </>) $ parseRelFile (dirnameString reportDir ++ ".tix")
ensureDir (parent tixDest)
liftIO $ writeTix (toFilePath tixDest) tix
generateHpcReportInternal tixDest reportDir report [] []
readTixOrLog :: HasLogFunc env => Path b File -> RIO env (Maybe Tix)
readTixOrLog path = do
mtix <- liftIO (readTix (toFilePath path)) `catchAny` \errorCall -> do
logError $
"Error: [S-3521]\n" <>
"Error while reading tix: " <>
fromString (displayException errorCall)
pure Nothing
when (isNothing mtix) $
logError $
"Error: [S-7786]\n" <>
"Failed to read tix file " <>
fromString (toFilePath path)
pure mtix
-- | Module names which contain '/' have a package name, and so they weren't built into the
-- executable.
removeExeModules :: Tix -> Tix
removeExeModules (Tix ms) = Tix (filter (\(TixModule name _ _ _) -> '/' `elem` name) ms)
unionTixes :: [Tix] -> ([String], Tix)
unionTixes tixes = (Map.keys errs, Tix (Map.elems outputs))
where
(errs, outputs) = Map.mapEither id $ Map.unionsWith merge $ map toMap tixes
toMap (Tix ms) = Map.fromList (map (\x@(TixModule k _ _ _) -> (k, Right x)) ms)
merge (Right (TixModule k hash1 len1 tix1))
(Right (TixModule _ hash2 len2 tix2))
| hash1 == hash2 && len1 == len2 = Right (TixModule k hash1 len1 (zipWith (+) tix1 tix2))
merge _ _ = Left ()
generateHpcMarkupIndex :: HasEnvConfig env => RIO env ()
generateHpcMarkupIndex = do
outputDir <- hpcReportDir
let outputFile = outputDir </> relFileIndexHtml
ensureDir outputDir
(dirs, _) <- listDir outputDir
rows <- liftM (catMaybes . concat) $ forM dirs $ \dir -> do
(subdirs, _) <- listDir dir
forM subdirs $ \subdir -> do
let indexPath = subdir </> relFileHpcIndexHtml
exists' <- doesFileExist indexPath
if not exists' then pure Nothing else do
relPath <- stripProperPrefix outputDir indexPath
let package = dirname dir
testsuite = dirname subdir
pure $ Just $ T.concat
[ "<tr><td>"
, pathToHtml package
, "</td><td><a href=\""
, pathToHtml relPath
, "\">"
, pathToHtml testsuite
, "</a></td></tr>"
]
writeBinaryFileAtomic outputFile $
"<html><head><meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\">" <>
-- Part of the css from HPC's output HTML
"<style type=\"text/css\">" <>
"table.dashboard { border-collapse: collapse; border: solid 1px black }" <>
".dashboard td { border: solid 1px black }" <>
".dashboard th { border: solid 1px black }" <>
"</style>" <>
"</head>" <>
"<body>" <>
(if null rows
then
"<b>No hpc_index.html files found in \"" <>
encodeUtf8Builder (pathToHtml outputDir) <>
"\".</b>"
else
"<table class=\"dashboard\" width=\"100%\" border=\"1\"><tbody>" <>
"<p><b>NOTE: This is merely a listing of the html files found in the coverage reports directory. Some of these reports may be old.</b></p>" <>
"<tr><th>Package</th><th>TestSuite</th><th>Modification Time</th></tr>" <>
foldMap encodeUtf8Builder rows <>
"</tbody></table>") <>
"</body></html>"
unless (null rows) $
displayReportPath "\nAn" "index of the generated HTML coverage reports"
(pretty outputFile)
generateHpcErrorReport :: MonadIO m => Path Abs Dir -> Utf8Builder -> m ()
generateHpcErrorReport dir err = do
ensureDir dir
let fp = toFilePath (dir </> relFileHpcIndexHtml)
writeFileUtf8Builder fp $
"<html><head><meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\"></head><body>" <>
"<h1>HPC Report Generation Error</h1>" <>
"<p>" <>
err <>
"</p>" <>
"</body></html>"
pathToHtml :: Path b t -> Text
pathToHtml = T.dropWhileEnd (=='/') . sanitize . toFilePath
-- | Escape HTML symbols (copied from Text.Hastache)
htmlEscape :: LT.Text -> LT.Text
htmlEscape = LT.concatMap proc_
where
proc_ '&' = "&"
proc_ '\\' = "\"
proc_ '"' = """
proc_ '\'' = "'"
proc_ '<' = "<"
proc_ '>' = ">"
proc_ h = LT.singleton h
sanitize :: String -> Text
sanitize = LT.toStrict . htmlEscape . LT.pack
dirnameString :: Path r Dir -> String
dirnameString = L.dropWhileEnd isPathSeparator . toFilePath . dirname
findPackageFieldForBuiltPackage
:: HasEnvConfig env
=> Path Abs Dir -> PackageIdentifier -> Set.Set Text -> Text
-> RIO env (Either Text [Text])
findPackageFieldForBuiltPackage pkgDir pkgId internalLibs field = do
distDir <- distDirFromDir pkgDir
let inplaceDir = distDir </> relDirPackageConfInplace
pkgIdStr = packageIdentifierString pkgId
notFoundErr = pure $ Left $ "Failed to find package key for " <> T.pack pkgIdStr
extractField path = do
contents <- readFileUtf8 (toFilePath path)
case asum (map (T.stripPrefix (field <> ": ")) (T.lines contents)) of
Just result -> pure $ Right $ T.strip result
Nothing -> notFoundErr
cabalVer <- view cabalVersionL
if cabalVer < mkVersion [1, 24]
then do
-- here we don't need to handle internal libs
path <- liftM (inplaceDir </>) $ parseRelFile (pkgIdStr ++ "-inplace.conf")
logDebug $ "Parsing config in Cabal < 1.24 location: " <> fromString (toFilePath path)
exists <- doesFileExist path
if exists then fmap (:[]) <$> extractField path else notFoundErr
else do
-- With Cabal-1.24, it's in a different location.
logDebug $ "Scanning " <> fromString (toFilePath inplaceDir) <> " for files matching " <> fromString pkgIdStr
(_, files) <- handleIO (const $ pure ([], [])) $ listDir inplaceDir
logDebug $ displayShow files
-- From all the files obtained from the scanning process above, we
-- need to identify which are .conf files and then ensure that
-- there is at most one .conf file for each library and internal
-- library (some might be missing if that component has not been
-- built yet). We should error if there are more than one .conf
-- file for a component or if there are no .conf files at all in
-- the searched location.
let toFilename = T.pack . toFilePath . filename
-- strip known prefix and suffix from the found files to determine only the conf files
stripKnown = T.stripSuffix ".conf" <=< T.stripPrefix (T.pack (pkgIdStr ++ "-"))
stripped = mapMaybe (\file -> fmap (,file) . stripKnown . toFilename $ file) files
-- which component could have generated each of these conf files
stripHash n = let z = T.dropWhile (/= '-') n in if T.null z then "" else T.tail z
matchedComponents = map (\(n, f) -> (stripHash n, [f])) stripped
byComponents = Map.restrictKeys (Map.fromListWith (++) matchedComponents) $ Set.insert "" internalLibs
logDebug $ displayShow byComponents
if Map.null $ Map.filter (\fs -> length fs > 1) byComponents
then case concat $ Map.elems byComponents of
[] -> notFoundErr
-- for each of these files, we need to extract the requested field
paths -> do
(errors, keys) <- partitionEithers <$> traverse extractField paths
case errors of
(a:_) -> pure $ Left a -- the first error only, since they're repeated anyway
[] -> pure $ Right keys
else pure $ Left $ "Multiple files matching " <> T.pack (pkgIdStr ++ "-*.conf") <> " found in " <>
T.pack (toFilePath inplaceDir) <> ". Maybe try 'stack clean' on this package?"
displayReportPath :: (HasTerm env)
=> StyleDoc -> Text -> StyleDoc -> RIO env ()
displayReportPath prefix report reportPath =
prettyInfo $ prefix <+> fromString (T.unpack report) <+>
"is available at" <+> reportPath
findExtraTixFiles :: HasEnvConfig env => RIO env [Path Abs File]
findExtraTixFiles = do
outputDir <- hpcReportDir
let dir = outputDir </> relDirExtraTixFiles
dirExists <- doesDirExist dir
if dirExists
then do
(_, files) <- listDir dir
pure $ filter ((".tix" `L.isSuffixOf`) . toFilePath) files
else pure []