{-# LANGUAGE ConstraintKinds #-}

{-# LANGUAGE FlexibleContexts #-}

{-# LANGUAGE MultiParamTypeClasses #-}

{-# LANGUAGE OverloadedStrings #-}

{-# LANGUAGE TemplateHaskell #-}

-- | Generate HPC (Haskell Program Coverage) reports

module Stack.Build.Coverage

( generateHpcReport

, generateHpcMarkupIndex

) where

import Control.Applicative

import Control.Exception.Lifted

import Control.Monad (liftM)

import Control.Monad.Catch (MonadCatch)

import Control.Monad.IO.Class

import Control.Monad.Logger

import Control.Monad.Reader (MonadReader, asks)

import Control.Monad.Trans.Resource

import qualified Data.ByteString.Char8 as S8

import Data.Foldable (forM_)

import Data.Function

import Data.List

import qualified Data.Map.Strict as Map

import Data.Maybe

import Data.Monoid ((<>))

import Data.Text (Text)

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 Data.Traversable (forM)

import Path

import Path.IO

import Prelude hiding (FilePath, writeFile)

import Stack.Constants

import Stack.Package

import Stack.Types

import System.Process.Read

import Text.Hastache (htmlEscape)

-- | Generates the HTML coverage report and shows a textual coverage

-- summary.

generateHpcReport :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env)

=> Path Abs Dir -> Package -> [Text] -> (PackageName -> m (Maybe Text)) -> m ()

generateHpcReport pkgDir package tests getGhcPkgKey = do

-- 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)

compilerVersion <- asks (envConfigCompilerVersion . getEnvConfig)

includeName <-

if getGhcVersion compilerVersion < $(mkVersion "7.10")

then return pkgId

else do

mghcPkgKey <- getGhcPkgKey (packageName package)

case mghcPkgKey of

Nothing -> fail $ "Before computing test coverage report, failed to find GHC package key for " ++ T.unpack pkgName

Just ghcPkgKey -> return $ T.unpack ghcPkgKey

forM_ tests $ \testName -> do

let whichTest = pkgName <> "'s test-suite \"" <> testName <> "\""

-- Compute destination directory.

installDir <- installationRootLocal

testNamePath <- parseRelDir (T.unpack testName)

pkgIdPath <- parseRelDir pkgId

let destDir = installDir </> hpcDirSuffix </> pkgIdPath </> testNamePath

-- Directories for .mix files.

hpcDir <- hpcDirFromDir pkgDir

hpcRelDir <- (</> dotHpc) <$> hpcRelativeDir

-- Compute arguments used for both "hpc markup" and "hpc report".

pkgDirs <- Map.keys . envConfigPackages <$> asks getEnvConfig

let args =

-- Use index files from all packages (allows cross-package

-- coverage results).

concatMap (\x -> ["--srcdir", toFilePath x]) pkgDirs ++

-- Look for index files in the correct dir (relative to

-- each pkgdir).

["--hpcdir", toFilePath hpcRelDir, "--reset-hpcdirs"

-- Restrict to just the current library code (see #634 -

-- this will likely be customizable in the future)

,"--include", includeName ++ ":"]

-- If a .tix file exists, generate an HPC report for it.

tixFile <- parseRelFile (T.unpack testName ++ ".tix")

let tixFileAbs = hpcDir </> tixFile

tixFileExists <- fileExists tixFileAbs

if not tixFileExists

then $logError $ T.concat

[ "Didn't find .tix coverage file for "

, whichTest

, " - expected to find it at "

, T.pack (toFilePath tixFileAbs)

, "."

]

else (`onException` $logError ("Error occurred while producing coverage report for " <> whichTest)) $ do

menv <- getMinimalEnvOverride

$logInfo $ "Generating HTML coverage report for " <> whichTest

_ <- readProcessStdout (Just hpcDir) menv "hpc"

("markup" : toFilePath tixFileAbs : ("--destdir=" ++ toFilePath destDir) : args)

output <- readProcessStdout (Just hpcDir) menv "hpc"

("report" : toFilePath tixFileAbs : args)

-- Print output, stripping @\r@ characters because

-- Windows.

forM_ (S8.lines output) ($logInfo . T.decodeUtf8 . S8.filter (not . (=='\r')))

$logInfo

("The HTML coverage report for " <> whichTest <> " is available at " <>

T.pack (toFilePath (destDir </> $(mkRelFile "hpc_index.html"))))

generateHpcMarkupIndex :: (MonadIO m,MonadReader env m,MonadLogger m,MonadCatch m,HasEnvConfig env)

=> m ()

generateHpcMarkupIndex = do

installDir <- installationRootLocal

let markupDir = installDir </> hpcDirSuffix

outputFile = markupDir </> $(mkRelFile "index.html")

(dirs, _) <- listDirectory markupDir

rows <- liftM (catMaybes . concat) $ forM dirs $ \dir -> do

(subdirs, _) <- listDirectory dir

forM subdirs $ \subdir -> do

let indexPath = subdir </> $(mkRelFile "hpc_index.html")

exists <- fileExists indexPath

if not exists then return Nothing else do

relPath <- stripDir markupDir 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\">"

-- 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 \""

, pathToHtml markupDir

, "\".</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></tr>"

] ++

rows ++

["</tbody></table>"]) ++

["</body></html>"]

$logInfo $ "\nAn index of the generated HTML coverage reports is available at " <>

T.pack (toFilePath outputFile)

pathToHtml :: Path b t -> Text

pathToHtml = T.dropWhileEnd (=='/') . LT.toStrict . htmlEscape . LT.pack . toFilePath