{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} -- | Generate HPC (Haskell Program Coverage) reports module Stack.Coverage ( deleteHpcReports , updateTixFile , generateHpcReport , HpcReportOpts(..) , generateHpcReportForTargets , generateHpcUnifiedReport , generateHpcMarkupIndex ) where import Stack.Prelude import qualified Data.ByteString.Char8 as S8 import Data.List import qualified Data.Map.Strict as Map import qualified Data.Text as T import qualified Data.Text.Encoding 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.Package import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Runner import Stack.Types.Version import System.FilePath (isPathSeparator) import System.Process.Read import Text.Hastache (htmlEscape) import Trace.Hpc.Tix import Web.Browser (openBrowser) -- | 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 $ "Failed to read " <> T.pack (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) return (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") return (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 = packageNameText (packageName package) pkgId = packageIdentifierString (packageIdentifier package) ghcVersion = getGhcVersion compilerVersion hasLibrary = case packageLibraries package of NoLibraries -> False HasLibraries _ -> True eincludeName <- -- Pre-7.8 uses plain PKG-version in tix files. if ghcVersion < $(mkVersion "7.10") then return $ Right $ Just pkgId -- We don't expect to find a package key if there is no library. else if not hasLibrary then return $ 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) hpcNameField case eincludeName of Left err -> do logError err return $ Left err Right includeName -> return $ Right $ Just $ T.unpack includeName 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 (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 Just includeName -> ["--include", includeName ++ ":"] 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 -- 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 $ T.concat [ "Didn't find .tix for " , report , " - expected to find it at " , T.pack (toFilePath tixSrc) , "." ] return Nothing else (`catch` \err -> do let msg = show (err :: ReadProcessException) logError (T.pack msg) generateHpcErrorReport reportDir $ sanitize msg return Nothing) $ (`onException` logError ("Error occurred while producing " <> report)) $ do -- Directories for .mix files. hpcRelDir <- hpcRelativeDir -- Compute arguments used for both "hpc markup" and "hpc report". pkgDirs <- liftM (map lpvRoot . Map.elems . lpProject) getLocalPackages 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"] menv <- getMinimalEnvOverride logInfo $ "Generating " <> report outputLines <- liftM (map (S8.filter (/= '\r')) . S8.lines) $ readProcessStdout Nothing menv "hpc" ( "report" : toFilePath tixSrc : (args ++ extraReportArgs) ) if all ("(0/0)" `S8.isSuffixOf`) outputLines then do let msg html = T.concat [ "Error: The " , 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 "" else "" , "issue #1008" , if html then "" 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") -- Print output, stripping @\r@ characters because Windows. forM_ outputLines (logInfo . T.decodeUtf8) -- Generate the markup. void $ readProcessStdout Nothing menv "hpc" ( "markup" : toFilePath tixSrc : ("--destdir=" ++ toFilePathNoTrailingSep reportDir) : (args ++ extraMarkupArgs) ) 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 <- -- 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 return [] else do when (hroptsAll opts && not (null targetNames)) $ logWarn $ "Since --all is used, it is redundant to specify these targets: " <> T.pack (show 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 $ T.concat [ if null tixFiles then "No tix files" else "Only one tix file" , " found in " , T.pack (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: " <> T.pack (show tixFiles) unless (null errs) $ logWarn $ T.concat $ "The following modules are left out of the " : report : " due to version mismatches: " : intersperse ", " (map T.pack errs) tixDest <- liftM (reportDir ) $ parseRelFile (dirnameString reportDir ++ ".tix") ensureDir (parent tixDest) liftIO $ writeTix (toFilePath tixDest) tix generateHpcReportInternal tixDest reportDir report [] [] readTixOrLog :: (MonadLogger m, MonadUnliftIO m) => Path b File -> m (Maybe Tix) readTixOrLog path = do mtix <- liftIO (readTix (toFilePath path)) `catchAny` \errorCall -> do logError $ "Error while reading tix: " <> T.pack (show errorCall) return Nothing when (isNothing mtix) $ logError $ "Failed to read tix file " <> T.pack (toFilePath path) return 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 $(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 [ "" , pathToHtml package , "" , pathToHtml testsuite , "" ] liftIO $ T.writeFile (toFilePath outputFile) $ T.concat $ [ "" -- Part of the css from HPC's output HTML , "" , "" , "" ] ++ (if null rows then [ "No hpc_index.html files found in \"" , 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.

" , "" ] ++ rows ++ ["
PackageTestSuiteModification Time
"]) ++ [""] unless (null rows) $ logInfo $ "\nAn index of the generated HTML coverage reports is available at " <> T.pack (toFilePath outputFile) generateHpcErrorReport :: MonadIO m => Path Abs Dir -> Text -> m () generateHpcErrorReport dir err = do ensureDir dir liftIO $ T.writeFile (toFilePath (dir $(mkRelFile "hpc_index.html"))) $ T.concat [ "" , "

HPC Report Generation Error

" , "

" , err , "

" , "" ] pathToHtml :: Path b t -> Text pathToHtml = T.dropWhileEnd (=='/') . sanitize . toFilePath 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 -> Text -> RIO env (Either Text Text) findPackageFieldForBuiltPackage pkgDir pkgId 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: " <> T.pack (toFilePath path) exists <- doesFileExist path if exists then extractField path else notFoundErr else do -- With Cabal-1.24, it's in a different location. logDebug $ "Scanning " <> T.pack (toFilePath inplaceDir) <> " for files matching " <> T.pack pkgIdStr (_, files) <- handleIO (const $ return ([], [])) $ listDir inplaceDir logDebug $ T.pack (show files) case mapMaybe (\file -> fmap (const file) . (T.stripSuffix ".conf" <=< T.stripPrefix (T.pack (pkgIdStr ++ "-"))) . T.pack . toFilePath . filename $ file) files of [] -> notFoundErr [path] -> extractField path _ -> 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 []