{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NoFieldSelectors      #-}
{-# LANGUAGE OverloadedRecordDot   #-}
{-# LANGUAGE OverloadedStrings     #-}

{-|
Module      : Stack.Coverage
Description : Generate HPC (Haskell Program Coverage) reports.
License     : BSD-3-Clause

Generate HPC (Haskell Program Coverage) reports.
-}

module Stack.Coverage
  ( hpcReportCmd
  , deleteHpcReports
  , updateTixFile
  , generateHpcReport
  , generateHpcUnifiedReport
  , generateHpcMarkupIndex
  ) where

import qualified Data.ByteString.Lazy.Char8 as L8
import           Data.Conduit ( await )
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.Types.MungedPackageId ( computeCompatPackageId )
import           Distribution.Types.UnqualComponentName
                   ( mkUnqualComponentName )
import           Path
                   ( (</>), dirname, 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
                   ( ExitCodeException, 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.PackageDump ( ghcPkgField )
import           Stack.Prelude
import           Stack.Runners ( ShouldReexec (..), withConfig, withEnvConfig )
import           Stack.Types.BuildConfig
                   ( BuildConfig (..), HasBuildConfig (..) )
import           Stack.Types.CompilerPaths ( getGhcPkgExe )
import           Stack.Types.CompCollection ( getBuildableSetText )
import           Stack.Types.ComponentUtils ( unqualCompToString )
import           Stack.Types.BuildOptsCLI
                   ( BuildOptsCLI (..), defaultBuildOptsCLI )
import           Stack.Types.EnvConfig
                   ( EnvConfig (..), HasEnvConfig (..), hpcReportDir )
import           Stack.Types.HpcReportOpts ( HpcReportOpts (..) )
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 Int -> CoveragePrettyException -> ShowS
[CoveragePrettyException] -> ShowS
CoveragePrettyException -> String
(Int -> CoveragePrettyException -> ShowS)
-> (CoveragePrettyException -> String)
-> ([CoveragePrettyException] -> ShowS)
-> Show CoveragePrettyException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CoveragePrettyException -> ShowS
showsPrec :: Int -> CoveragePrettyException -> ShowS
$cshow :: CoveragePrettyException -> String
show :: CoveragePrettyException -> String
$cshowList :: [CoveragePrettyException] -> ShowS
showList :: [CoveragePrettyException] -> ShowS
Show

instance Pretty CoveragePrettyException where
  pretty :: CoveragePrettyException -> StyleDoc
pretty (NonTestSuiteTarget PackageName
name) =
    StyleDoc
"[S-6361]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ String -> StyleDoc
flow String
"Can't specify anything except test-suites as hpc report \
                \targets"
         , StyleDoc -> StyleDoc
parens (Style -> StyleDoc -> StyleDoc
style Style
Target (StyleDoc -> StyleDoc)
-> (PackageName -> StyleDoc) -> PackageName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName (PackageName -> StyleDoc) -> PackageName -> StyleDoc
forall a b. (a -> b) -> a -> b
$ PackageName
name)
         , String -> StyleDoc
flow String
"is used with a non test-suite target."
         ]
  pretty CoveragePrettyException
NoTargetsOrTixSpecified =
    StyleDoc
"[S-2321]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"Not generating combined report, because no targets or tix files \
            \are specified."
  pretty (NotLocalPackage PackageName
name) =
    StyleDoc
"[S-9975]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ String -> StyleDoc
flow String
"Expected a project package, but"
         , Style -> StyleDoc -> StyleDoc
style Style
Target (StyleDoc -> StyleDoc)
-> (PackageName -> StyleDoc) -> PackageName -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName (PackageName -> StyleDoc) -> PackageName -> StyleDoc
forall a b. (a -> b) -> a -> b
$ PackageName
name
         , String -> StyleDoc
flow String
"is either an extra-dep or in the snapshot."
         ]

instance Exception CoveragePrettyException

-- | Function underlying the @stack hpc report@ command.

hpcReportCmd :: HpcReportOpts -> RIO Runner ()
hpcReportCmd :: HpcReportOpts -> RIO Runner ()
hpcReportCmd HpcReportOpts
hropts = do
  let ([Text]
tixFiles, [Text]
targetNames) =
        (Text -> Bool) -> [Text] -> ([Text], [Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition (Text
".tix" Text -> Text -> Bool
`T.isSuffixOf`) HpcReportOpts
hropts.inputs
      boptsCLI :: BuildOptsCLI
boptsCLI = BuildOptsCLI
defaultBuildOptsCLI
        { targetsCLI = if hropts.all then [] else targetNames }
  ShouldReexec -> RIO Config () -> RIO Runner ()
forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
YesReexec (RIO Config () -> RIO Runner ()) -> RIO Config () -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$ NeedTargets -> BuildOptsCLI -> RIO EnvConfig () -> RIO Config ()
forall a.
NeedTargets -> BuildOptsCLI -> RIO EnvConfig a -> RIO Config a
withEnvConfig NeedTargets
AllowNoTargets BuildOptsCLI
boptsCLI (RIO EnvConfig () -> RIO Config ())
-> RIO EnvConfig () -> RIO Config ()
forall a b. (a -> b) -> a -> b
$
    HpcReportOpts -> [Text] -> [Text] -> RIO EnvConfig ()
forall env.
HasEnvConfig env =>
HpcReportOpts -> [Text] -> [Text] -> RIO env ()
generateHpcReportForTargets HpcReportOpts
hropts [Text]
tixFiles [Text]
targetNames

-- | Invoked at the beginning of running with "--coverage"

deleteHpcReports :: HasEnvConfig env => RIO env ()
deleteHpcReports :: forall env. HasEnvConfig env => RIO env ()
deleteHpcReports = do
  hpcDir <- RIO env (Path Abs Dir)
forall env. HasEnvConfig env => RIO env (Path Abs Dir)
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 :: forall env.
HasEnvConfig env =>
PackageName -> Path Abs File -> String -> RIO env ()
updateTixFile PackageName
pkgName' Path Abs File
tixSrc String
testName = do
  exists <- Path Abs File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
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

    readTixOrLog tixSrc >>= \case
      Maybe Tix
Nothing -> StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyError (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
        StyleDoc
"[S-2887]"
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
             [ String -> StyleDoc
flow String
"Failed to read"
             , Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
tixSrc StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
             ]
      Just Tix
tix -> do
        IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ String -> Tix -> IO ()
writeTix (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
tixDest) (Tix -> Tix
removeExeModules Tix
tix)
        -- TODO: ideally we'd do a file move, but IIRC this can

        -- have problems. Something about moving between drives

        -- on windows?

        Path Abs File -> Path Abs File -> RIO env ()
forall (m :: * -> *) b0 b1.
MonadIO m =>
Path b0 File -> Path b1 File -> m ()
copyFile Path Abs File
tixSrc (Path Abs File -> RIO env ())
-> RIO env (Path Abs File) -> RIO env ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> RIO env (Path Abs File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs File)
parseAbsFile (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
tixDest String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".premunging")
        IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (m :: * -> *) a. (MonadIO m, MonadCatch m) => m a -> m ()
ignoringAbsence (Path Abs File -> IO ()
forall (m :: * -> *) b. MonadIO m => Path b File -> m ()
removeFile Path Abs File
tixSrc)

-- | Get the directory used for hpc reports for the given pkgId.

hpcPkgPath :: HasEnvConfig env => PackageName -> RIO env (Path Abs Dir)
hpcPkgPath :: forall env.
HasEnvConfig env =>
PackageName -> RIO env (Path Abs Dir)
hpcPkgPath PackageName
pkgName' = do
  outputDir <- RIO env (Path Abs Dir)
forall env. HasEnvConfig env => RIO env (Path Abs Dir)
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 :: forall env.
HasEnvConfig env =>
PackageName -> String -> RIO env (Path Abs File)
tixFilePath PackageName
pkgName' String
testName = do
  pkgPath <- PackageName -> RIO env (Path Abs Dir)
forall env.
HasEnvConfig env =>
PackageName -> RIO env (Path Abs Dir)
hpcPkgPath PackageName
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 :: forall env.
HasEnvConfig env =>
Path Abs Dir -> Package -> [Text] -> RIO env ()
generateHpcReport Path Abs Dir
pkgDir Package
package [Text]
tests = 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' :: String
pkgName' = PackageName -> String
packageNameString Package
package.name
      hasLibrary :: Bool
hasLibrary = Package -> Bool
hasBuildableMainLibrary Package
package
      subLibs :: CompCollection StackLibrary
subLibs = Package
package.subLibraries
  eincludeName <-
    if Bool -> Bool
not Bool
hasLibrary Bool -> Bool -> Bool
&& CompCollection StackLibrary -> Bool
forall a. CompCollection a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null CompCollection StackLibrary
subLibs
      -- We don't expect to find a package key if there is no library.

      then Either Text (Maybe [String])
-> RIO env (Either Text (Maybe [String]))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text (Maybe [String])
 -> RIO env (Either Text (Maybe [String])))
-> Either Text (Maybe [String])
-> RIO env (Either Text (Maybe [String]))
forall a b. (a -> b) -> a -> b
$ Maybe [String] -> Either Text (Maybe [String])
forall a b. b -> Either a b
Right Maybe [String]
forall a. Maybe a
Nothing
      -- Look in the inplace DB for the package key.

      -- See https://github.com/commercialhaskell/stack/issues/1181#issuecomment-148968986

      else do
        eincludeName <-
          Path Abs Dir
-> PackageIdentifier
-> Set Text
-> Text
-> RIO env (Either Text [Text])
forall env.
HasEnvConfig env =>
Path Abs Dir
-> PackageIdentifier
-> Set Text
-> Text
-> RIO env (Either Text [Text])
findPackageFieldForBuiltPackage
            Path Abs Dir
pkgDir
            (Package -> PackageIdentifier
packageIdentifier Package
package)
            (CompCollection StackLibrary -> Set Text
forall component. CompCollection component -> Set Text
getBuildableSetText CompCollection StackLibrary
subLibs)
            -- GHC 8.0 uses package id instead of package key.

            -- See https://github.com/commercialhaskell/stack/issues/2424

            Text
"id"
        case eincludeName of
          Left Text
err -> do
            Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
err
            Either Text (Maybe [String])
-> RIO env (Either Text (Maybe [String]))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text (Maybe [String])
 -> RIO env (Either Text (Maybe [String])))
-> Either Text (Maybe [String])
-> RIO env (Either Text (Maybe [String]))
forall a b. (a -> b) -> a -> b
$ Text -> Either Text (Maybe [String])
forall a b. a -> Either a b
Left Text
err
          Right [Text]
includeNames -> Either Text (Maybe [String])
-> RIO env (Either Text (Maybe [String]))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text (Maybe [String])
 -> RIO env (Either Text (Maybe [String])))
-> Either Text (Maybe [String])
-> RIO env (Either Text (Maybe [String]))
forall a b. (a -> b) -> a -> b
$ Maybe [String] -> Either Text (Maybe [String])
forall a b. b -> Either a b
Right (Maybe [String] -> Either Text (Maybe [String]))
-> Maybe [String] -> Either Text (Maybe [String])
forall a b. (a -> b) -> a -> b
$ [String] -> Maybe [String]
forall a. a -> Maybe a
Just ([String] -> Maybe [String]) -> [String] -> Maybe [String]
forall a b. (a -> b) -> a -> b
$ (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack [Text]
includeNames
  forM_ tests $ \Text
testName -> do
    tixSrc <- PackageName -> String -> RIO env (Path Abs File)
forall env.
HasEnvConfig env =>
PackageName -> String -> RIO env (Path Abs File)
tixFilePath Package
package.name (Text -> String
T.unpack Text
testName)
    let report = [StyleDoc] -> StyleDoc
fillSep
          [ String -> StyleDoc
flow String
"coverage report for"
          , Style -> StyleDoc -> StyleDoc
style Style
Current (String -> StyleDoc
forall a. IsString a => String -> a
fromString String
pkgName') StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"'s"
          , StyleDoc
"test-suite"
          , Style -> StyleDoc -> StyleDoc
style Style
PkgComponent (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
testName)
          ]
        reportHtml =
             Text
"coverage report for"
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
pkgName'
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'s test-suite \""
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
testName
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""
        reportDir = Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
tixSrc
    case eincludeName of
      Left Text
err -> Path Abs Dir -> Utf8Builder -> RIO env ()
forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> Utf8Builder -> m ()
generateHpcErrorReport Path Abs Dir
reportDir (Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (String -> Text
sanitize (Text -> String
T.unpack Text
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 Maybe [String]
mincludeName -> do
        let extraArgs :: [String]
extraArgs = case Maybe [String]
mincludeName of
              Maybe [String]
Nothing -> []
              Just [String]
includeNames ->
                  String
"--include"
                String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String] -> [String]
forall a. a -> [a] -> [a]
L.intersperse String
"--include" (ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":") [String]
includeNames)
        mreportPath <-
          Path Abs File
-> Path Abs Dir
-> StyleDoc
-> Text
-> [String]
-> [String]
-> RIO env (Maybe (Path Abs File))
forall env.
HasEnvConfig env =>
Path Abs File
-> Path Abs Dir
-> StyleDoc
-> Text
-> [String]
-> [String]
-> RIO env (Maybe (Path Abs File))
generateHpcReportInternal Path Abs File
tixSrc Path Abs Dir
reportDir StyleDoc
report Text
reportHtml [String]
extraArgs [String]
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 :: forall env.
HasEnvConfig env =>
Path Abs File
-> Path Abs Dir
-> StyleDoc
-> Text
-> [String]
-> [String]
-> RIO env (Maybe (Path Abs File))
generateHpcReportInternal
    Path Abs File
tixSrc
    Path Abs Dir
reportDir
    StyleDoc
report
    Text
reportHtml
    [String]
extraMarkupArgs
    [String]
extraReportArgs
  = do
      -- If a .tix file exists, move it to the HPC output directory and generate

      -- a report for it.

      tixFileExists <- Path Abs File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
tixSrc
      if not tixFileExists
        then do
          prettyError $
            "[S-4634]"
            <> line
            <> fillSep
                 [ flow "Didn't find"
                 , style File ".tix"
                 , "for"
                 , report
                 , flow "- expected to find it at"
                 , pretty tixSrc <> "."
                 ]
          pure Nothing
        else (`catch` \(ProcessException
err :: ProcessException) -> do
               Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ ProcessException -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow ProcessException
err
               Path Abs Dir -> Utf8Builder -> RIO env ()
forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> Utf8Builder -> m ()
generateHpcErrorReport Path Abs Dir
reportDir (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (Text -> Utf8Builder) -> Text -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ String -> Text
sanitize (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$
                   ProcessException -> String
forall e. Exception e => e -> String
displayException ProcessException
err
               Maybe (Path Abs File) -> RIO env (Maybe (Path Abs File))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Path Abs File)
forall a. Maybe a
Nothing) $
           (`onException`
               prettyError
                 ( "[S-8215]"
                   <> line
                   <> fillSep
                        [ 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).

                (Path Abs Dir -> [String]) -> [Path Abs Dir] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Path Abs Dir
x -> [String
"--srcdir", Path Abs Dir -> String
forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
x]) [Path Abs Dir]
pkgDirs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
                -- Look for index files in the correct dir (relative to each pkgdir).

                [String
"--hpcdir", Path Rel Dir -> String
forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Rel Dir
hpcRelDir, String
"--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 =
                       Utf8Builder
"Error: [S-6829]\n\
                       \The "
                    Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
reportHtml
                    Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" did not consider any code. One possible cause of this is \
                       \if your test-suite builds the library code (see Stack \
                       \<a href='https://github.com/commercialhaskell/stack/issues/1008'>\
                       \issue #1008\
                       \</a>\
                       \). 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 = Path Abs Dir
reportDir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
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 :: forall env.
HasEnvConfig env =>
HpcReportOpts -> [Text] -> [Text] -> RIO env ()
generateHpcReportForTargets HpcReportOpts
opts [Text]
tixFiles [Text]
targetNames = do
  targetTixFiles <-
    -- When there aren't any package component arguments, and --all

    -- isn't passed, default to not considering any targets.

    if Bool -> Bool
not HpcReportOpts
opts.all Bool -> Bool -> Bool
&& [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
targetNames
    then [Path Abs File] -> RIO env [Path Abs File]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    else do
      Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HpcReportOpts
opts.all Bool -> Bool -> Bool
&& Bool -> Bool
not ([Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
targetNames)) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
        [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
          ([StyleDoc] -> RIO env ()) -> [StyleDoc] -> RIO env ()
forall a b. (a -> b) -> a -> b
$ StyleDoc
"Since"
          StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"--all"
          StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: String -> StyleDoc
flow String
"is used, it is redundant to specify these targets:"
          StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: Maybe Style -> Bool -> [StyleDoc] -> [StyleDoc]
forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList (Style -> Maybe Style
forall a. a -> Maybe a
Just Style
Target) Bool
False
              ((Text -> StyleDoc) -> [Text] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> (Text -> String) -> Text -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) [Text]
targetNames :: [StyleDoc])
      targets <-
        Getting (Map PackageName Target) env (Map PackageName Target)
-> RIO env (Map PackageName Target)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting (Map PackageName Target) env (Map PackageName Target)
 -> RIO env (Map PackageName Target))
-> Getting (Map PackageName Target) env (Map PackageName Target)
-> RIO env (Map PackageName Target)
forall a b. (a -> b) -> a -> b
$ (EnvConfig -> Const (Map PackageName Target) EnvConfig)
-> env -> Const (Map PackageName Target) env
forall env. HasEnvConfig env => Lens' env EnvConfig
Lens' env EnvConfig
envConfigL ((EnvConfig -> Const (Map PackageName Target) EnvConfig)
 -> env -> Const (Map PackageName Target) env)
-> ((Map PackageName Target
     -> Const (Map PackageName Target) (Map PackageName Target))
    -> EnvConfig -> Const (Map PackageName Target) EnvConfig)
-> Getting (Map PackageName Target) env (Map PackageName Target)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EnvConfig -> Map PackageName Target)
-> SimpleGetter EnvConfig (Map PackageName Target)
forall s a. (s -> a) -> SimpleGetter s a
to (.sourceMap.targets.targets)
      fmap concat $ forM (Map.toList targets) $ \(PackageName
name, Target
target) ->
        case Target
target of
          TargetAll PackageType
PTDependency -> CoveragePrettyException -> RIO env [Path Abs File]
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (CoveragePrettyException -> RIO env [Path Abs File])
-> CoveragePrettyException -> RIO env [Path Abs File]
forall a b. (a -> b) -> a -> b
$ PackageName -> CoveragePrettyException
NotLocalPackage PackageName
name
          TargetComps Set NamedComponent
comps -> do
            pkgPath <- PackageName -> RIO env (Path Abs Dir)
forall env.
HasEnvConfig env =>
PackageName -> RIO env (Path Abs Dir)
hpcPkgPath PackageName
name
            forM (toList comps) $
              \case
                CTest StackUnqualCompName
testName -> (Path Abs Dir
pkgPath Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</>) (Path Rel File -> Path Abs File)
-> RIO env (Path Rel File) -> RIO env (Path Abs File)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                  String -> RIO env (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile
                    (  String
testName'
                    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/"
                    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
testName'
                    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".tix"
                    )
                 where
                  testName' :: String
testName' = StackUnqualCompName -> String
unqualCompToString StackUnqualCompName
testName
                NamedComponent
_ -> CoveragePrettyException -> RIO env (Path Abs File)
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (CoveragePrettyException -> RIO env (Path Abs File))
-> CoveragePrettyException -> RIO env (Path Abs File)
forall a b. (a -> b) -> a -> b
$ PackageName -> CoveragePrettyException
NonTestSuiteTarget PackageName
name
          TargetAll PackageType
PTProject -> do
            pkgPath <- PackageName -> RIO env (Path Abs Dir)
forall env.
HasEnvConfig env =>
PackageName -> RIO env (Path Abs Dir)
hpcPkgPath PackageName
name
            exists <- doesDirExist pkgPath
            if exists
              then do
                (dirs, _) <- listDir pkgPath
                fmap concat $ forM dirs $ \Path Abs Dir
dir -> do
                  (_, files) <- Path Abs Dir -> RIO env ([Path Abs Dir], [Path Abs File])
forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
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
    Maybe String
Nothing -> Path Abs Dir -> RIO env (Path Abs Dir)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir
outputDir Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirCombined Path Rel Dir -> Path Rel Dir -> Path Rel Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirCustom)
    Just String
destDir -> do
      dest <- String -> RIO env (Path Abs Dir)
forall (m :: * -> *). MonadIO m => String -> m (Path Abs Dir)
resolveDir' String
destDir
      ensureDir dest
      pure dest
  let report = String -> StyleDoc
flow String
"combined coverage report"
      reportHtml = Text
"combined coverage report"
  mreportPath <- generateUnionReport report reportHtml reportDir tixPaths
  forM_ mreportPath $ \Path Abs File
reportPath ->
    if HpcReportOpts
opts.openBrowser
      then do
        StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$ StyleDoc
"Opening" StyleDoc -> StyleDoc -> StyleDoc
<+> Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
reportPath StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc
"in the browser."
        RIO env Bool -> RIO env ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (RIO env Bool -> RIO env ()) -> RIO env Bool -> RIO env ()
forall a b. (a -> b) -> a -> b
$ IO Bool -> RIO env Bool
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> RIO env Bool) -> IO Bool -> RIO env Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
openBrowser (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
reportPath)
      else StyleDoc -> StyleDoc -> StyleDoc -> RIO env ()
forall env.
HasTerm env =>
StyleDoc -> StyleDoc -> StyleDoc -> RIO env ()
displayReportPath StyleDoc
"The" StyleDoc
report (Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
reportPath)

-- | Generates the HTML unified coverage report.

generateHpcUnifiedReport :: HasEnvConfig env => RIO env ()
generateHpcUnifiedReport :: forall env. HasEnvConfig env => RIO env ()
generateHpcUnifiedReport = do
  outputDir <- RIO env (Path Abs Dir)
forall env. HasEnvConfig env => RIO env (Path Abs Dir)
hpcReportDir
  ensureDir outputDir
  (dirs, _) <- listDir outputDir
  tixFiles0 <-
    fmap (concat . concat) $ forM (filter (("combined" /=) . dirnameString) dirs) $ \Path Abs Dir
dir -> do
      (dirs', _) <- Path Abs Dir -> RIO env ([Path Abs Dir], [Path Abs File])
forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
dir
      forM dirs' $ \Path Abs Dir
dir' -> do
        (_, files) <- Path Abs Dir -> RIO env ([Path Abs Dir], [Path Abs File])
forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
dir'
        pure (filter ((".tix" `L.isSuffixOf`) . toFilePath) files)
  extraTixFiles <- findExtraTixFiles
  let tixFiles = [Path Abs File]
tixFiles0  [Path Abs File] -> [Path Abs File] -> [Path Abs File]
forall a. [a] -> [a] -> [a]
++ [Path Abs File]
extraTixFiles
      reportDir = Path Abs Dir
outputDir Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirCombined Path Rel Dir -> Path Rel Dir -> Path Rel Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
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 = String -> StyleDoc
flow String
"unified coverage report"
          reportHtml = Text
"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 :: forall env.
HasEnvConfig env =>
StyleDoc
-> Text
-> Path Abs Dir
-> [Path Abs File]
-> RIO env (Maybe (Path Abs File))
generateUnionReport StyleDoc
report Text
reportHtml Path Abs Dir
reportDir [Path Abs File]
tixFiles = do
  (errs, tix) <- ([Tix] -> ([String], Tix))
-> RIO env [Tix] -> RIO env ([String], Tix)
forall a b. (a -> b) -> RIO env a -> RIO env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Tix] -> ([String], Tix)
unionTixes ([Tix] -> ([String], Tix))
-> ([Tix] -> [Tix]) -> [Tix] -> ([String], Tix)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tix -> Tix) -> [Tix] -> [Tix]
forall a b. (a -> b) -> [a] -> [b]
map Tix -> Tix
removeExeModules) ((Path Abs File -> RIO env (Maybe Tix))
-> [Path Abs File] -> RIO env [Tix]
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM Path Abs File -> RIO env (Maybe Tix)
forall env b. HasTerm env => Path b File -> RIO env (Maybe Tix)
readTixOrLog [Path Abs File]
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 :: forall env b. HasTerm env => Path b File -> RIO env (Maybe Tix)
readTixOrLog Path b File
path = do
  mtix <- IO (Maybe Tix) -> RIO env (Maybe Tix)
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO (Maybe Tix)
readTix (Path b File -> String
forall b t. Path b t -> String
toFilePath Path b File
path)) RIO env (Maybe Tix)
-> (SomeException -> RIO env (Maybe Tix)) -> RIO env (Maybe Tix)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
errorCall -> do
    StyleDoc -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyError (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
      StyleDoc
"[S-3521]"
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"Error while reading tix:"
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
string (SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
errorCall)
    Maybe Tix -> RIO env (Maybe Tix)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Tix
forall a. Maybe a
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 -> Tix
removeExeModules (Tix [TixModule]
ms) =
  [TixModule] -> Tix
Tix ((TixModule -> Bool) -> [TixModule] -> [TixModule]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(TixModule String
name Hash
_ Int
_ [Integer]
_) -> Char
'/' Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
name) [TixModule]
ms)

unionTixes :: [Tix] -> ([String], Tix)
unionTixes :: [Tix] -> ([String], Tix)
unionTixes [Tix]
tixes = (Map String () -> [String]
forall k a. Map k a -> [k]
Map.keys Map String ()
errs, [TixModule] -> Tix
Tix (Map String TixModule -> [TixModule]
forall k a. Map k a -> [a]
Map.elems Map String TixModule
outputs))
 where
  (Map String ()
errs, Map String TixModule
outputs) = (Either () TixModule -> Either () TixModule)
-> Map String (Either () TixModule)
-> (Map String (), Map String TixModule)
forall a b c k. (a -> Either b c) -> Map k a -> (Map k b, Map k c)
Map.mapEither Either () TixModule -> Either () TixModule
forall a. a -> a
id (Map String (Either () TixModule)
 -> (Map String (), Map String TixModule))
-> Map String (Either () TixModule)
-> (Map String (), Map String TixModule)
forall a b. (a -> b) -> a -> b
$ (Either () TixModule -> Either () TixModule -> Either () TixModule)
-> [Map String (Either () TixModule)]
-> Map String (Either () TixModule)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith Either () TixModule -> Either () TixModule -> Either () TixModule
forall {a} {a}.
Either a TixModule -> Either a TixModule -> Either () TixModule
merge ([Map String (Either () TixModule)]
 -> Map String (Either () TixModule))
-> [Map String (Either () TixModule)]
-> Map String (Either () TixModule)
forall a b. (a -> b) -> a -> b
$ (Tix -> Map String (Either () TixModule))
-> [Tix] -> [Map String (Either () TixModule)]
forall a b. (a -> b) -> [a] -> [b]
map Tix -> Map String (Either () TixModule)
forall {a}. Tix -> Map String (Either a TixModule)
toMap [Tix]
tixes
  toMap :: Tix -> Map String (Either a TixModule)
toMap (Tix [TixModule]
ms) = [(String, Either a TixModule)] -> Map String (Either a TixModule)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ((TixModule -> (String, Either a TixModule))
-> [TixModule] -> [(String, Either a TixModule)]
forall a b. (a -> b) -> [a] -> [b]
map (\x :: TixModule
x@(TixModule String
k Hash
_ Int
_ [Integer]
_) -> (String
k, TixModule -> Either a TixModule
forall a b. b -> Either a b
Right TixModule
x)) [TixModule]
ms)
  merge :: Either a TixModule -> Either a TixModule -> Either () TixModule
merge (Right (TixModule String
k Hash
hash1 Int
len1 [Integer]
tix1))
      (Right (TixModule String
_ Hash
hash2 Int
len2 [Integer]
tix2))
    | Hash
hash1 Hash -> Hash -> Bool
forall a. Eq a => a -> a -> Bool
== Hash
hash2 Bool -> Bool -> Bool
&& Int
len1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
len2 =
        TixModule -> Either () TixModule
forall a b. b -> Either a b
Right (String -> Hash -> Int -> [Integer] -> TixModule
TixModule String
k Hash
hash1 Int
len1 ((Integer -> Integer -> Integer)
-> [Integer] -> [Integer] -> [Integer]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(+) [Integer]
tix1 [Integer]
tix2))
  merge Either a TixModule
_ Either a TixModule
_ = () -> Either () TixModule
forall a b. a -> Either a b
Left ()

-- | Generates the HTML index report.

generateHpcMarkupIndex :: HasEnvConfig env => RIO env ()
generateHpcMarkupIndex :: forall env. HasEnvConfig env => RIO env ()
generateHpcMarkupIndex = do
  outputDir <- RIO env (Path Abs Dir)
forall env. HasEnvConfig env => RIO env (Path Abs Dir)
hpcReportDir
  let outputFile = Path Abs Dir
outputDir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileIndexHtml
  ensureDir outputDir
  (dirs, _) <- listDir outputDir
  rows <- fmap (concatMap catMaybes) $ forM dirs $ \Path Abs Dir
dir -> do
    (subdirs, _) <- Path Abs Dir -> RIO env ([Path Abs Dir], [Path Abs File])
forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
dir
    forM subdirs $ \Path Abs Dir
subdir -> do
      let indexPath :: Path Abs File
indexPath = Path Abs Dir
subdir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileHpcIndexHtml
      exists' <- Path Abs File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
indexPath
      if not exists' then pure Nothing else do
        relPath <- stripProperPrefix outputDir indexPath
        let package = Path Abs Dir -> Path Rel Dir
forall b. Path b Dir -> Path Rel Dir
dirname Path Abs Dir
dir
            testsuite = Path Abs Dir -> Path Rel Dir
forall b. Path b Dir -> Path Rel Dir
dirname Path Abs Dir
subdir
        pure $ Just $ T.concat
          [ "<tr><td>"
          , pathToHtml package
          , "</td><td><a href=\""
          , pathToHtml relPath
          , "\">"
          , pathToHtml testsuite
          , "</a></td></tr>"
          ]
  writeBinaryFileAtomic outputFile $
       "<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 \""
             <> encodeUtf8Builder (pathToHtml outputDir)
             <> "\".</b>"
           else
                "<table class=\"dashboard\" width=\"100%\" border=\"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><th>Modification Time</th></tr>"
             <> foldMap encodeUtf8Builder rows
             <> "</tbody></table>"
       )
    <> "</body></html>"
  unless (null rows) $
    displayReportPath
      "\nAn" "index of the generated HTML coverage reports"
      (pretty outputFile)

generateHpcErrorReport :: MonadIO m => Path Abs Dir -> Utf8Builder -> m ()
generateHpcErrorReport :: forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> Utf8Builder -> m ()
generateHpcErrorReport Path Abs Dir
dir Utf8Builder
err = do
  Path Abs Dir -> m ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
dir
  let fp :: String
fp = Path Abs File -> String
forall b t. Path b t -> String
toFilePath (Path Abs Dir
dir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileHpcIndexHtml)
  String -> Utf8Builder -> m ()
forall (m :: * -> *). MonadIO m => String -> Utf8Builder -> m ()
writeFileUtf8Builder String
fp (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall a b. (a -> b) -> a -> b
$
       Utf8Builder
"<html><head><meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\"></head><body>"
    Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"<h1>HPC Report Generation Error</h1>"
    Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"<p>"
    Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
err
    Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"</p>"
    Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"</body></html>"

pathToHtml :: Path b t -> Text
pathToHtml :: forall b t. Path b t -> Text
pathToHtml = (Char -> Bool) -> Text -> Text
T.dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'/') (Text -> Text) -> (Path b t -> Text) -> Path b t -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
sanitize (String -> Text) -> (Path b t -> String) -> Path b t -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path b t -> String
forall b t. Path b t -> String
toFilePath

-- | Escape HTML symbols (copied from Text.Hastache)

htmlEscape :: LT.Text -> LT.Text
htmlEscape :: Text -> Text
htmlEscape = (Char -> Text) -> Text -> Text
LT.concatMap Char -> Text
proc_
 where
  proc_ :: Char -> Text
proc_ Char
'&'  = Text
"&amp;"
  proc_ Char
'\\' = Text
"&#92;"
  proc_ Char
'"'  = Text
"&quot;"
  proc_ Char
'\'' = Text
"&#39;"
  proc_ Char
'<'  = Text
"&lt;"
  proc_ Char
'>'  = Text
"&gt;"
  proc_ Char
h    = Char -> Text
LT.singleton Char
h

sanitize :: String -> Text
sanitize :: String -> Text
sanitize = Text -> Text
LT.toStrict (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
htmlEscape (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
LT.pack

dirnameString :: Path r Dir -> String
dirnameString :: forall loc. Path loc Dir -> String
dirnameString = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
L.dropWhileEnd Char -> Bool
isPathSeparator ShowS -> (Path r Dir -> String) -> Path r Dir -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Rel Dir -> String
forall b t. Path b t -> String
toFilePath (Path Rel Dir -> String)
-> (Path r Dir -> Path Rel Dir) -> Path r Dir -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path r Dir -> Path Rel Dir
forall b. Path b Dir -> Path Rel Dir
dirname

findPackageFieldForBuiltPackage ::
     HasEnvConfig env
  => Path Abs Dir -> PackageIdentifier -> Set.Set Text -> Text
  -> RIO env (Either Text [Text])
findPackageFieldForBuiltPackage :: forall env.
HasEnvConfig env =>
Path Abs Dir
-> PackageIdentifier
-> Set Text
-> Text
-> RIO env (Either Text [Text])
findPackageFieldForBuiltPackage Path Abs Dir
pkgDir PackageIdentifier
pkgId Set Text
subLibs Text
field = do
  let subLibNames :: Set LibraryName
subLibNames =
        (Text -> LibraryName) -> Set Text -> Set LibraryName
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (UnqualComponentName -> LibraryName
LSubLibName (UnqualComponentName -> LibraryName)
-> (Text -> UnqualComponentName) -> Text -> LibraryName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> UnqualComponentName
mkUnqualComponentName (String -> UnqualComponentName)
-> (Text -> String) -> Text -> UnqualComponentName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) Set Text
subLibs
      libraryNames :: Set LibraryName
libraryNames = LibraryName -> Set LibraryName -> Set LibraryName
forall a. Ord a => a -> Set a -> Set a
Set.insert LibraryName
LMainLibName Set LibraryName
subLibNames
      mungedPackageIds :: Set MungedPackageId
mungedPackageIds = (LibraryName -> MungedPackageId)
-> Set LibraryName -> Set MungedPackageId
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (PackageIdentifier -> LibraryName -> MungedPackageId
computeCompatPackageId PackageIdentifier
pkgId) Set LibraryName
libraryNames
  distDir <- Path Abs Dir -> RIO env (Path Abs Dir)
forall env (m :: * -> *).
(HasEnvConfig env, MonadReader env m, MonadThrow m) =>
Path Abs Dir -> m (Path Abs Dir)
distDirFromDir Path Abs Dir
pkgDir
  ghcPkgExe <- getGhcPkgExe
  let inplaceDir = Path Abs Dir
distDir Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirPackageConfInplace
      pkgIdStr = PackageIdentifier -> String
packageIdentifierString PackageIdentifier
pkgId
      notFoundErr = Either Text Text -> RIO env (Either Text Text)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text Text -> RIO env (Either Text Text))
-> Either Text Text -> RIO env (Either Text Text)
forall a b. (a -> b) -> a -> b
$
        Text -> Either Text Text
forall a b. a -> Either a b
Left (Text -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$ Text
"Failed to find package key for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
pkgIdStr
      extractField MungedPackageId
mungedPkgId = do
        mContents <- RIO env (Maybe Text)
-> (ExitCodeException -> RIO env (Maybe Text))
-> RIO env (Maybe Text)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch
          (GhcPkgExe
-> Path Abs Dir
-> MungedPackageId
-> String
-> ConduitM Text Void (RIO env) (Maybe Text)
-> RIO env (Maybe Text)
forall env a.
(HasCompiler env, HasProcessContext env, HasTerm env) =>
GhcPkgExe
-> Path Abs Dir
-> MungedPackageId
-> String
-> ConduitM Text Void (RIO env) a
-> RIO env a
ghcPkgField GhcPkgExe
ghcPkgExe Path Abs Dir
inplaceDir MungedPackageId
mungedPkgId (Text -> String
T.unpack Text
field) ConduitM Text Void (RIO env) (Maybe Text)
forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await)
          -- A .conf file may not exist in the package database for a library or

          -- sub-library, if that component has not been built yet.

          (\(ExitCodeException
_ :: ExitCodeException) -> Maybe Text -> RIO env (Maybe Text)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing)
        case mContents of
          Just Text
result -> Either Text Text -> RIO env (Either Text Text)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text Text -> RIO env (Either Text Text))
-> Either Text Text -> RIO env (Either Text Text)
forall a b. (a -> b) -> a -> b
$ Text -> Either Text Text
forall a b. b -> Either a b
Right (Text -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.strip Text
result
          Maybe Text
Nothing -> RIO env (Either Text Text)
notFoundErr
  logDebug $
       "Scanning "
    <> fromString (toFilePath inplaceDir)
    <> " for munged packages matching "
    <> fromString pkgIdStr
  (errors, keys) <-
    partitionEithers <$> traverse extractField (Set.toList mungedPackageIds)
  case errors of
    (Text
a:[Text]
_) -> Either Text [Text] -> RIO env (Either Text [Text])
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text [Text] -> RIO env (Either Text [Text]))
-> Either Text [Text] -> RIO env (Either Text [Text])
forall a b. (a -> b) -> a -> b
$ Text -> Either Text [Text]
forall a b. a -> Either a b
Left Text
a -- the first error only, since they're repeated anyway

    [] -> Either Text [Text] -> RIO env (Either Text [Text])
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text [Text] -> RIO env (Either Text [Text]))
-> Either Text [Text] -> RIO env (Either Text [Text])
forall a b. (a -> b) -> a -> b
$ [Text] -> Either Text [Text]
forall a b. b -> Either a b
Right [Text]
keys

displayReportPath ::
     HasTerm env
  => StyleDoc
  -> StyleDoc
  -> StyleDoc
  -> RIO env ()
displayReportPath :: forall env.
HasTerm env =>
StyleDoc -> StyleDoc -> StyleDoc -> RIO env ()
displayReportPath StyleDoc
prefix StyleDoc
report StyleDoc
reportPath =
  [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
    [ StyleDoc
prefix
    , StyleDoc
report
    , String -> StyleDoc
flow String
"is available at"
    , StyleDoc
reportPath StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
    ]

findExtraTixFiles :: HasEnvConfig env => RIO env [Path Abs File]
findExtraTixFiles :: forall env. HasEnvConfig env => RIO env [Path Abs File]
findExtraTixFiles = do
  outputDir <- RIO env (Path Abs Dir)
forall env. HasEnvConfig env => RIO env (Path Abs Dir)
hpcReportDir
  let dir = Path Abs Dir
outputDir Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirExtraTixFiles
  dirExists <- doesDirExist dir
  if dirExists
    then do
      (_, files) <- listDir dir
      pure $ filter ((".tix" `L.isSuffixOf`) . toFilePath) files
    else pure []