{-# 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 "" 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) 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 [ "" , 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 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 []