{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
module Stack.Coverage
( deleteHpcReports
, updateTixFile
, generateHpcReport
, HpcReportOpts(..)
, generateHpcReportForTargets
, generateHpcUnifiedReport
, generateHpcMarkupIndex
) where
import Stack.Prelude hiding (Display (..))
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as BL
import Data.List
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Text.Lazy as LT
import Path
import Path.Extra (toFilePathNoTrailingSep)
import Path.IO
import Stack.Build.Target
import Stack.Config (getLocalPackages)
import Stack.Constants.Config
import Stack.Package
import Stack.PrettyPrint
import Stack.Types.Compiler
import Stack.Types.Config
import Stack.Types.NamedComponent
import Stack.Types.Package
import Stack.Types.PackageIdentifier
import Stack.Types.PackageName
import Stack.Types.Runner
import Stack.Types.Version
import System.FilePath (isPathSeparator)
import qualified RIO
import RIO.Process
import Trace.Hpc.Tix
import Web.Browser (openBrowser)
deleteHpcReports :: HasEnvConfig env => RIO env ()
deleteHpcReports = do
hpcDir <- hpcReportDir
liftIO $ ignoringAbsence (removeDirRecur hpcDir)
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)
mtix <- readTixOrLog tixSrc
case mtix of
Nothing -> logError $ "Failed to read " <> fromString (toFilePath tixSrc)
Just tix -> do
liftIO $ writeTix (toFilePath tixDest) (removeExeModules tix)
copyFile tixSrc =<< parseAbsFile (toFilePath tixDest ++ ".premunging")
liftIO $ ignoringAbsence (removeFile tixSrc)
hpcPkgPath :: HasEnvConfig env => PackageName -> RIO env (Path Abs Dir)
hpcPkgPath pkgName = do
outputDir <- hpcReportDir
pkgNameRel <- parseRelDir (packageNameString pkgName)
return (outputDir </> pkgNameRel)
tixFilePath :: HasEnvConfig env
=> PackageName -> String -> RIO env (Path Abs File)
tixFilePath pkgName testName = do
pkgPath <- hpcPkgPath pkgName
tixRel <- parseRelFile (testName ++ "/" ++ testName ++ ".tix")
return (pkgPath </> tixRel)
generateHpcReport :: HasEnvConfig env
=> Path Abs Dir -> Package -> [Text] -> RIO env ()
generateHpcReport pkgDir package tests = do
compilerVersion <- view actualCompilerVersionL
let pkgName = packageNameText (packageName package)
pkgId = packageIdentifierString (packageIdentifier package)
ghcVersion = getGhcVersion compilerVersion
hasLibrary =
case packageLibraries package of
NoLibraries -> False
HasLibraries _ -> True
internalLibs = packageInternalLibraries package
eincludeName <-
if ghcVersion < $(mkVersion "7.10") then return $ Right $ Just [pkgId]
else if not hasLibrary && Set.null internalLibs then return $ Right Nothing
else do
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 $ RIO.display err
return $ Left err
Right includeNames -> return $ 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 (RIO.display (sanitize (T.unpack err)))
Right mincludeName -> do
let extraArgs = case mincludeName of
Just includeNames -> "--include" : intersperse "--include" (map (\n -> n ++ ":") includeNames)
Nothing -> []
mreportPath <- generateHpcReportInternal tixSrc reportDir report extraArgs extraArgs
forM_ mreportPath (displayReportPath report . display)
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
tixFileExists <- doesFileExist tixSrc
if not tixFileExists
then do
logError $
"Didn't find .tix for " <>
RIO.display report <>
" - expected to find it at " <>
fromString (toFilePath tixSrc) <>
"."
return Nothing
else (`catch` \(err :: ProcessException) -> do
logError $ displayShow err
generateHpcErrorReport reportDir $ RIO.display $ sanitize $ show err
return Nothing) $
(`onException` logError ("Error occurred while producing " <> RIO.display report)) $ do
hpcRelDir <- hpcRelativeDir
pkgDirs <- liftM (map lpvRoot . Map.elems . lpProject) getLocalPackages
let args =
concatMap (\x -> ["--srcdir", toFilePathNoTrailingSep x]) pkgDirs ++
["--hpcdir", toFilePathNoTrailingSep hpcRelDir, "--reset-hpcdirs"]
logInfo $ "Generating " <> RIO.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: The " <>
RIO.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)
return Nothing
else do
let reportPath = reportDir </> $(mkRelFile "hpc_index.html")
forM_ outputLines (logInfo . displayBytesUtf8)
void $ proc "hpc"
( "markup"
: toFilePath tixSrc
: ("--destdir=" ++ toFilePathNoTrailingSep reportDir)
: (args ++ extraMarkupArgs)
)
readProcess_
return (Just reportPath)
data HpcReportOpts = HpcReportOpts
{ hroptsInputs :: [Text]
, hroptsAll :: Bool
, hroptsDestDir :: Maybe String
, hroptsOpenBrowser :: Bool
} deriving (Show)
generateHpcReportForTargets :: HasEnvConfig env
=> HpcReportOpts -> RIO env ()
generateHpcReportForTargets opts = do
let (tixFiles, targetNames) = partition (".tix" `T.isSuffixOf`) (hroptsInputs opts)
targetTixFiles <-
if not (hroptsAll opts) && null targetNames
then return []
else do
when (hroptsAll opts && not (null targetNames)) $
logWarn $ "Since --all is used, it is redundant to specify these targets: " <> displayShow targetNames
(_,_,targets) <- parseTargets
AllowNoTargets
defaultBuildOptsCLI
{ boptsCLITargets = if hroptsAll opts then [] else targetNames }
liftM concat $ forM (Map.toList targets) $ \(name, target) ->
case target of
TargetAll Dependency -> throwString $
"Error: Expected a local package, but " ++
packageNameString name ++
" is either an extra-dep or in the snapshot."
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")
_ -> fail $
"Can't specify anything except test-suites as hpc report targets (" ++
packageNameString name ++
" is used with a non test-suite target)"
TargetAll ProjectPackage -> do
pkgPath <- hpcPkgPath name
exists <- doesDirExist pkgPath
if exists
then do
(dirs, _) <- listDir pkgPath
liftM concat $ forM dirs $ \dir -> do
(_, files) <- listDir dir
return (filter ((".tix" `isSuffixOf`) . toFilePath) files)
else return []
tixPaths <- liftM (\xs -> xs ++ targetTixFiles) $ mapM (resolveFile' . T.unpack) tixFiles
when (null tixPaths) $
throwString "Not generating combined report, because no targets or tix files are specified."
outputDir <- hpcReportDir
reportDir <- case hroptsDestDir opts of
Nothing -> return (outputDir </> $(mkRelDir "combined/custom"))
Just destDir -> do
dest <- resolveDir' destDir
ensureDir dest
return dest
let report = "combined report"
mreportPath <- generateUnionReport report reportDir tixPaths
forM_ mreportPath $ \reportPath ->
if hroptsOpenBrowser opts
then do
prettyInfo $ "Opening" <+> display reportPath <+> "in the browser."
void $ liftIO $ openBrowser (toFilePath reportPath)
else displayReportPath report (display 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'
return (filter ((".tix" `isSuffixOf`) . toFilePath) files)
extraTixFiles <- findExtraTixFiles
let tixFiles = tixFiles0 ++ extraTixFiles
reportDir = outputDir </> $(mkRelDir "combined/all")
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 do
let report = "unified report"
mreportPath <- generateUnionReport report reportDir tixFiles
forM_ mreportPath (displayReportPath report . display)
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 " <>
RIO.display report <>
" due to version mismatches: " <>
mconcat (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 while reading tix: " <> fromString (show errorCall)
return Nothing
when (isNothing mtix) $
logError $ "Failed to read tix file " <> fromString (toFilePath path)
return mtix
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 </> $(mkRelFile "index.html")
ensureDir outputDir
(dirs, _) <- listDir outputDir
rows <- liftM (catMaybes . concat) $ forM dirs $ \dir -> do
(subdirs, _) <- listDir dir
forM subdirs $ \subdir -> do
let indexPath = subdir </> $(mkRelFile "hpc_index.html")
exists' <- doesFileExist indexPath
if not exists' then return Nothing else do
relPath <- stripProperPrefix outputDir indexPath
let package = dirname dir
testsuite = dirname subdir
return $ Just $ T.concat
[ "<tr><td>"
, pathToHtml package
, "</td><td><a href=\""
, pathToHtml relPath
, "\">"
, pathToHtml testsuite
, "</a></td></tr>"
]
liftIO $ T.writeFile (toFilePath outputFile) $ T.concat $
[ "<html><head><meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\">"
, "<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 \""
, pathToHtml outputDir
, "\".</b>"
]
else
[ "<table class=\"dashboard\" width=\"100%\" boder=\"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>"
] ++
rows ++
["</tbody></table>"]) ++
["</body></html>"]
unless (null rows) $
logInfo $ "\nAn index of the generated HTML coverage reports is available at " <>
fromString (toFilePath outputFile)
generateHpcErrorReport :: MonadIO m => Path Abs Dir -> Utf8Builder -> m ()
generateHpcErrorReport dir err = do
ensureDir dir
let fp = toFilePath (dir </> $(mkRelFile "hpc_index.html"))
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
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 = 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 </> $(mkRelDir "package.conf.inplace")
pkgIdStr = packageIdentifierString pkgId
notFoundErr = return $ Left $ "Failed to find package key for " <> T.pack pkgIdStr
extractField path = do
contents <- liftIO $ T.readFile (toFilePath path)
case asum (map (T.stripPrefix (field <> ": ")) (T.lines contents)) of
Just result -> return $ Right result
Nothing -> notFoundErr
cabalVer <- view cabalVersionL
if cabalVer < $(mkVersion "1.24")
then do
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
logDebug $ "Scanning " <> fromString (toFilePath inplaceDir) <> " for files matching " <> fromString pkgIdStr
(_, files) <- handleIO (const $ return ([], [])) $ listDir inplaceDir
logDebug $ displayShow files
let toFilename = T.pack . toFilePath . filename
stripKnown = T.stripSuffix ".conf" <=< T.stripPrefix (T.pack (pkgIdStr ++ "-"))
stripped = mapMaybe (\file -> fmap (,file) . stripKnown . toFilename $ file) 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
paths -> do
(errors, keys) <- partitionEithers <$> traverse extractField paths
case errors of
(a:_) -> return $ Left a
[] -> return $ Right keys
else return $ Left $ "Multiple files matching " <> T.pack (pkgIdStr ++ "-*.conf") <> " found in " <>
T.pack (toFilePath inplaceDir) <> ". Maybe try 'stack clean' on this package?"
displayReportPath :: (HasRunner env)
=> Text -> AnsiDoc -> RIO env ()
displayReportPath report reportPath =
prettyInfo $ "The" <+> fromString (T.unpack report) <+> "is available at" <+> reportPath
findExtraTixFiles :: HasEnvConfig env => RIO env [Path Abs File]
findExtraTixFiles = do
outputDir <- hpcReportDir
let dir = outputDir </> $(mkRelDir "extra-tix-files")
dirExists <- doesDirExist dir
if dirExists
then do
(_, files) <- listDir dir
return $ filter ((".tix" `isSuffixOf`) . toFilePath) files
else return []