{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoFieldSelectors #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} -- | Generate HPC (Haskell Program Coverage) reports module Stack.Coverage ( HpcReportOpts (..) , hpcReportCmd , deleteHpcReports , updateTixFile , generateHpcReport , generateHpcReportForTargets , generateHpcUnifiedReport , generateHpcMarkupIndex ) where import qualified Data.ByteString.Lazy.Char8 as L8 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 ( (), dirname, filename, parent, parseAbsFile, parseRelDir , parseRelFile, stripProperPrefix ) import Path.Extra ( toFilePathNoTrailingSep ) import Path.IO ( copyFile, doesDirExist, doesFileExist, ensureDir , ignoringAbsence, listDir, removeDirRecur, removeFile , resolveDir', resolveFile' ) import RIO.ByteString.Lazy ( putStrLn ) import RIO.Process ( ProcessException, proc, readProcess_ ) import Stack.Build.Target ( NeedTargets (..) ) import Stack.Constants ( relDirAll, relDirCombined, relDirCustom , relDirExtraTixFiles, relDirPackageConfInplace , relFileHpcIndexHtml, relFileIndexHtml ) import Stack.Constants.Config ( distDirFromDir, hpcRelativeDir ) import Stack.Package ( hasBuildableMainLibrary ) import Stack.Prelude import Stack.Runners ( ShouldReexec (..), withConfig, withEnvConfig ) import Stack.Types.BuildConfig ( BuildConfig (..), HasBuildConfig (..) ) import Stack.Types.Compiler ( getGhcVersion ) import Stack.Types.CompCollection ( getBuildableSetText ) import Stack.Types.BuildOptsCLI ( BuildOptsCLI (..), defaultBuildOptsCLI ) import Stack.Types.EnvConfig ( EnvConfig (..), HasEnvConfig (..), actualCompilerVersionL , hpcReportDir ) import Stack.Types.NamedComponent ( NamedComponent (..) ) import Stack.Types.Package ( Package (..), packageIdentifier ) import Stack.Types.Runner ( Runner ) import Stack.Types.SourceMap ( PackageType (..), SMTargets (..), SMWanted (..) , SourceMap (..), Target (..), ppRoot ) import System.FilePath ( isPathSeparator ) import Trace.Hpc.Tix ( Tix (..), TixModule (..), readTix, writeTix ) import Web.Browser ( openBrowser ) -- | Type representing \'pretty\' exceptions thrown by functions exported by the -- "Stack.Coverage" module. data CoveragePrettyException = NonTestSuiteTarget PackageName | NoTargetsOrTixSpecified | NotLocalPackage PackageName deriving (Show, Typeable) instance Pretty CoveragePrettyException where pretty (NonTestSuiteTarget name) = "[S-6361]" <> line <> fillSep [ flow "Can't specify anything except test-suites as hpc report \ \targets" , parens (style Target . fromPackageName $ name) , flow "is used with a non test-suite target." ] pretty NoTargetsOrTixSpecified = "[S-2321]" <> line <> flow "Not generating combined report, because no targets or tix files \ \are specified." pretty (NotLocalPackage name) = "[S-9975]" <> line <> fillSep [ flow "Expected a local package, but" , style Target . fromPackageName $ name , flow "is either an extra-dep or in the snapshot." ] instance Exception CoveragePrettyException -- | Type representing command line options for the @stack hpc report@ command. data HpcReportOpts = HpcReportOpts { inputs :: [Text] , all :: Bool , destDir :: Maybe String , openBrowser :: Bool } deriving Show -- | Function underlying the @stack hpc report@ command. hpcReportCmd :: HpcReportOpts -> RIO Runner () hpcReportCmd hropts = do let (tixFiles, targetNames) = L.partition (".tix" `T.isSuffixOf`) hropts.inputs boptsCLI = defaultBuildOptsCLI { targetsCLI = if hropts.all then [] else targetNames } withConfig YesReexec $ withEnvConfig AllowNoTargets boptsCLI $ generateHpcReportForTargets hropts tixFiles targetNames -- | 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 -> prettyError $ "[S-2887]" <> line <> fillSep [ flow "Failed to read" , pretty 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 pkgId = packageIdentifierString $ packageIdentifier package pkgName' = packageNameString package.name ghcVersion = getGhcVersion compilerVersion hasLibrary = hasBuildableMainLibrary package subLibs = package.subLibraries 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 && null subLibs 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) (getBuildableSetText subLibs) 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 package.name (T.unpack testName) let report = fillSep [ flow "coverage report for" , style Current (fromString pkgName') <> "'s" , "test-suite" , style PkgComponent (fromString $ T.unpack testName) ] reportHtml = "coverage report for" <> T.pack 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 (++ ":") includeNames) mreportPath <- generateHpcReportInternal tixSrc reportDir report reportHtml extraArgs extraArgs forM_ mreportPath (displayReportPath "The" report . pretty) generateHpcReportInternal :: HasEnvConfig env => Path Abs File -> Path Abs Dir -> StyleDoc -- ^ The pretty name for the report -> Text -- ^ The plain name for the report, used in HTML output -> [String] -> [String] -> RIO env (Maybe (Path Abs File)) generateHpcReportInternal tixSrc reportDir report reportHtml 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 prettyError $ "[S-4634]" <> line <> flow "Didn't find" <> style File ".tix" <> "for" <> report <> flow "- expected to find it at" <> pretty tixSrc <> "." pure Nothing else (`catch` \(err :: ProcessException) -> do logError $ displayShow err generateHpcErrorReport reportDir $ display $ sanitize $ displayException err pure Nothing) $ (`onException` prettyError ( "[S-8215]" <> line <> flow "Error occurred while producing" <> 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 . (.smWanted.project)) 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"] prettyInfoL [ "Generating" , report <> "." ] -- Strip @\r@ characters because Windows. outputLines <- map (L8.filter (/= '\r')) . L8.lines . fst <$> proc "hpc" ( "report" : toFilePath tixSrc : (args ++ extraReportArgs) ) readProcess_ if all ("(0/0)" `L8.isSuffixOf`) outputLines then do let msgHtml = "Error: [S-6829]\n\ \The " <> display reportHtml <> " did not consider any code. One possible cause of this is \ \if your test-suite builds the library code (see Stack \ \\ \issue #1008\ \\ \). 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." prettyError $ "[S-6829]" <> line <> fillSep [ "The" , report , flow "did not consider any code. One possible cause of this \ \is if your test-suite builds the library code (see \ \Stack issue #1008). 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." ] generateHpcErrorReport reportDir msgHtml pure Nothing else do let reportPath = reportDir relFileHpcIndexHtml -- Print the summary report to the standard output stream. putUtf8Builder =<< displayWithColor ( fillSep [ "Summary" , report <> ":" ] <> line ) forM_ outputLines putStrLn -- Generate the HTML markup. void $ proc "hpc" ( "markup" : toFilePath tixSrc : ("--destdir=" ++ toFilePathNoTrailingSep reportDir) : (args ++ extraMarkupArgs) ) readProcess_ pure (Just reportPath) 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 opts.all && null targetNames then pure [] else do when (opts.all && not (null targetNames)) $ prettyWarnL $ "Since" : style Shell "--all" : flow "is used, it is redundant to specify these targets:" : mkNarrativeList (Just Target) False (map (fromString . T.unpack) targetNames :: [StyleDoc]) targets <- view $ envConfigL . to (.sourceMap.targets.targets) fmap concat $ forM (Map.toList targets) $ \(name, target) -> case target of TargetAll PTDependency -> prettyThrowIO $ NotLocalPackage name TargetComps comps -> do pkgPath <- hpcPkgPath name forM (toList comps) $ \case CTest testName -> (pkgPath ) <$> parseRelFile ( T.unpack testName ++ "/" ++ T.unpack testName ++ ".tix" ) _ -> prettyThrowIO $ NonTestSuiteTarget name TargetAll PTProject -> do pkgPath <- hpcPkgPath name exists <- doesDirExist pkgPath if exists then do (dirs, _) <- listDir pkgPath fmap concat $ forM dirs $ \dir -> do (_, files) <- listDir dir pure (filter ((".tix" `L.isSuffixOf`) . toFilePath) files) else pure [] tixPaths <- (++ targetTixFiles) <$> mapM (resolveFile' . T.unpack) tixFiles when (null tixPaths) $ prettyThrowIO NoTargetsOrTixSpecified outputDir <- hpcReportDir reportDir <- case opts.destDir of Nothing -> pure (outputDir relDirCombined relDirCustom) Just destDir -> do dest <- resolveDir' destDir ensureDir dest pure dest let report = flow "combined coverage report" reportHtml = "combined coverage report" mreportPath <- generateUnionReport report reportHtml reportDir tixPaths forM_ mreportPath $ \reportPath -> if opts.openBrowser 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 <- fmap (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 -- 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 prettyInfoL [ flow "No tix files found in" , pretty outputDir <> "," , flow "so not generating a unified coverage report." ] else do let report = flow "unified coverage report" reportHtml = "unified coverage report" mreportPath <- generateUnionReport report reportHtml reportDir tixFiles forM_ mreportPath (displayReportPath "The" report . pretty) generateUnionReport :: HasEnvConfig env => StyleDoc -- ^ Pretty description of the report. -> Text -- ^ Plain description of the report, used in HTML reporting. -> Path Abs Dir -> [Path Abs File] -> RIO env (Maybe (Path Abs File)) generateUnionReport report reportHtml reportDir tixFiles = do (errs, tix) <- fmap (unionTixes . map removeExeModules) (mapMaybeM readTixOrLog tixFiles) logDebug $ "Using the following tix files: " <> fromString (show tixFiles) unless (null errs) $ prettyWarn $ fillSep [ flow "The following modules are left out of the" , report , flow "due to version mismatches:" ] <> line <> bulletedList (map fromString errs :: [StyleDoc]) tixDest <- (reportDir ) <$> parseRelFile (dirnameString reportDir ++ ".tix") ensureDir (parent tixDest) liftIO $ writeTix (toFilePath tixDest) tix generateHpcReportInternal tixDest reportDir report reportHtml [] [] readTixOrLog :: HasTerm env => Path b File -> RIO env (Maybe Tix) readTixOrLog path = do mtix <- liftIO (readTix (toFilePath path)) `catchAny` \errorCall -> do prettyError $ "[S-3521]" <> line <> flow "Error while reading tix:" <> line <> string (displayException errorCall) pure Nothing when (isNothing mtix) $ prettyError $ "[S-7786]" <> line <> fillSep [ flow "Failed to read tix file" , pretty 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 <- fmap (concatMap catMaybes) $ 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 [ "" , pathToHtml package , "" , pathToHtml testsuite , "" ] writeBinaryFileAtomic outputFile $ "" <> -- Part of the css from HPC's output HTML "" <> "" <> "" <> ( if null rows then "No hpc_index.html files found in \"" <> encodeUtf8Builder (pathToHtml outputDir) <> "\"." else "" <> "

NOTE: This is merely a listing of the html files found in the coverage reports directory. Some of these reports may be old.

" <> "" <> foldMap encodeUtf8Builder rows <> "
PackageTestSuiteModification Time
" ) <> "" 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 $ "" <> "

HPC Report Generation Error

" <> "

" <> err <> "

" <> "" 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 subLibs 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 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 sub-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 "" subLibs 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 -> StyleDoc -> StyleDoc -> RIO env () displayReportPath prefix report reportPath = prettyInfoL [ prefix , report , flow "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 []