<commit_before>{-# 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")
    exists <- dirExists markupDir
    dirs <- if exists then liftM fst (listDirectory markupDir) else return []
    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<commit_msg>Create hpc report directory if it doesn't exist #1006<commit_after>{-# 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")
    createTree markupDir
    (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
{'fraction_non_alphanumeric': 0.09315286624203821, 'fraction_numerical': 0.0028951939779965257, 'mean_word_length': 1.7236349300216833, 'pattern_counts': {'":': 2, '<': 108, '<?xml version=': 0, '>': 93, 'https://': 2, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '2856215', 'n_tokens_mistral': 3849, 'n_tokens_neox': 3587, 'n_words': 1089}