{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE OverloadedStrings     #-}

-- | Generate HPC (Haskell Program Coverage) reports

module Stack.Coverage
  ( HpcReportOpts (..)
  , hpcReportCmd
  , deleteHpcReports
  , updateTixFile
  , generateHpcReport
  , 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
                   ( (</>), dirname, filename, parent, parseAbsFile, parseRelDir
                   , parseRelFile, stripProperPrefix
                   )
import           Path.Extra ( toFilePathNoTrailingSep )
import           Path.IO
                   ( copyFile, doesDirExist, doesFileExist, ensureDir
                   , ignoringAbsence, listDir, removeDirRecur, removeFile
                   , resolveDir', resolveFile'
                   )
import           RIO.Process ( 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.Prelude
import           Stack.Runners ( ShouldReexec (..), withConfig, withEnvConfig )
import           Stack.Types.BuildConfig
                   ( BuildConfig (..), HasBuildConfig (..) )
import           Stack.Types.Compiler ( getGhcVersion )
import           Stack.Types.CompilerPaths ( cabalVersionL )
import           Stack.Types.BuildOpts ( BuildOptsCLI (..), defaultBuildOptsCLI )
import           Stack.Types.EnvConfig
                   ( EnvConfig (..), HasEnvConfig (..), actualCompilerVersionL
                   , hpcReportDir
                   )
import           Stack.Types.NamedComponent ( NamedComponent (..) )
import           Stack.Types.Package
                   ( Package (..), PackageLibraries (..), 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CoveragePrettyException] -> ShowS
$cshowList :: [CoveragePrettyException] -> ShowS
show :: CoveragePrettyException -> String
$cshow :: CoveragePrettyException -> String
showsPrec :: Int -> CoveragePrettyException -> ShowS
$cshowsPrec :: Int -> CoveragePrettyException -> ShowS
Show, Typeable)

instance Pretty CoveragePrettyException where
  pretty :: CoveragePrettyException -> StyleDoc
pretty (NonTestSuiteTarget PackageName
name) =
    StyleDoc
"[S-6361]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString 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]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    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]"
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ String -> StyleDoc
flow String
"Expected a local package, but"
         , Style -> StyleDoc -> StyleDoc
style Style
Target forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString 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

-- | Type representing command line options for the @stack hpc report@ command.

data HpcReportOpts = HpcReportOpts
  { HpcReportOpts -> [Text]
hroptsInputs :: [Text]
  , HpcReportOpts -> Bool
hroptsAll :: Bool
  , HpcReportOpts -> Maybe String
hroptsDestDir :: Maybe String
  , HpcReportOpts -> Bool
hroptsOpenBrowser :: Bool
  }
  deriving Int -> HpcReportOpts -> ShowS
[HpcReportOpts] -> ShowS
HpcReportOpts -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HpcReportOpts] -> ShowS
$cshowList :: [HpcReportOpts] -> ShowS
show :: HpcReportOpts -> String
$cshow :: HpcReportOpts -> String
showsPrec :: Int -> HpcReportOpts -> ShowS
$cshowsPrec :: Int -> HpcReportOpts -> ShowS
Show

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

hpcReportCmd :: HpcReportOpts -> RIO Runner ()
hpcReportCmd :: HpcReportOpts -> RIO Runner ()
hpcReportCmd HpcReportOpts
hropts = do
  let ([Text]
tixFiles, [Text]
targetNames) =
        forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition (Text
".tix" `T.isSuffixOf`) (HpcReportOpts -> [Text]
hroptsInputs HpcReportOpts
hropts)
      boptsCLI :: BuildOptsCLI
boptsCLI = BuildOptsCLI
defaultBuildOptsCLI
        { boptsCLITargets :: [Text]
boptsCLITargets = if HpcReportOpts -> Bool
hroptsAll HpcReportOpts
hropts then [] else [Text]
targetNames }
  forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
YesReexec forall a b. (a -> b) -> a -> b
$ forall a.
NeedTargets -> BuildOptsCLI -> RIO EnvConfig a -> RIO Config a
withEnvConfig NeedTargets
AllowNoTargets BuildOptsCLI
boptsCLI forall a b. (a -> b) -> a -> b
$
    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
  Path Abs Dir
hpcDir <- forall env. HasEnvConfig env => RIO env (Path Abs Dir)
hpcReportDir
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (MonadIO m, MonadCatch m) => m a -> m ()
ignoringAbsence (forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
removeDirRecur Path Abs Dir
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
  Bool
exists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
tixSrc
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists forall a b. (a -> b) -> a -> b
$ do
    Path Abs File
tixDest <- forall env.
HasEnvConfig env =>
PackageName -> String -> RIO env (Path Abs File)
tixFilePath PackageName
pkgName' String
testName
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (MonadIO m, MonadCatch m) => m a -> m ()
ignoringAbsence (forall (m :: * -> *) b. MonadIO m => Path b File -> m ()
removeFile Path Abs File
tixDest)
    forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (forall b t. Path b t -> Path b Dir
parent Path Abs File
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

    Maybe Tix
mtix <- forall env b. HasTerm env => Path b File -> RIO env (Maybe Tix)
readTixOrLog Path Abs File
tixSrc
    case Maybe Tix
mtix of
      Maybe Tix
Nothing -> forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyError forall a b. (a -> b) -> a -> b
$
        StyleDoc
"[S-2887]"
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
        forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
             [ String -> StyleDoc
flow String
"Failed to read"
             , forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
tixSrc forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
             ]
      Just Tix
tix -> do
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> Tix -> IO ()
writeTix (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?

        forall (m :: * -> *) b0 b1.
MonadIO m =>
Path b0 File -> Path b1 File -> m ()
copyFile Path Abs File
tixSrc forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). MonadThrow m => String -> m (Path Abs File)
parseAbsFile (forall b t. Path b t -> String
toFilePath Path Abs File
tixDest forall a. [a] -> [a] -> [a]
++ String
".premunging")
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (MonadIO m, MonadCatch m) => m a -> m ()
ignoringAbsence (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
  Path Abs Dir
outputDir <- forall env. HasEnvConfig env => RIO env (Path Abs Dir)
hpcReportDir
  Path Rel Dir
pkgNameRel <- forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir (PackageName -> String
packageNameString PackageName
pkgName')
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir
outputDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
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
  Path Abs Dir
pkgPath <- forall env.
HasEnvConfig env =>
PackageName -> RIO env (Path Abs Dir)
hpcPkgPath PackageName
pkgName'
  Path Rel File
tixRel <- forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile (String
testName forall a. [a] -> [a] -> [a]
++ String
"/" forall a. [a] -> [a] -> [a]
++ String
testName forall a. [a] -> [a] -> [a]
++ String
".tix")
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir
pkgPath forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
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
  ActualCompiler
compilerVersion <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasSourceMap env => SimpleGetter env ActualCompiler
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 pkgId :: String
pkgId = PackageIdentifier -> String
packageIdentifierString (Package -> PackageIdentifier
packageIdentifier Package
package)
      pkgName' :: String
pkgName' = PackageName -> String
packageNameString forall a b. (a -> b) -> a -> b
$ Package -> PackageName
packageName Package
package
      ghcVersion :: Version
ghcVersion = ActualCompiler -> Version
getGhcVersion ActualCompiler
compilerVersion
      hasLibrary :: Bool
hasLibrary =
        case Package -> PackageLibraries
packageLibraries Package
package of
          PackageLibraries
NoLibraries -> Bool
False
          HasLibraries Set Text
_ -> Bool
True
      internalLibs :: Set Text
internalLibs = Package -> Set Text
packageInternalLibraries Package
package
  Either Text (Maybe [String])
eincludeName <-
    -- Pre-7.8 uses plain PKG-version in tix files.

    if Version
ghcVersion forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
7, Int
10] then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just [String
pkgId]
    -- We don't expect to find a package key if there is no library.

    else if Bool -> Bool
not Bool
hasLibrary Bool -> Bool -> Bool
&& forall a. Set a -> Bool
Set.null Set Text
internalLibs then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right 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
      -- GHC 8.0 uses package id instead of package key.

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

      let hpcNameField :: Text
hpcNameField = if Version
ghcVersion forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
8, Int
0] then Text
"id" else Text
"key"
      Either Text [Text]
eincludeName <-
        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)
          Set Text
internalLibs
          Text
hpcNameField
      case Either Text [Text]
eincludeName of
        Left Text
err -> do
          forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Utf8Builder
display Text
err
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Text
err
        Right [Text]
includeNames -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack [Text]
includeNames
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Text]
tests forall a b. (a -> b) -> a -> b
$ \Text
testName -> do
    Path Abs File
tixSrc <- forall env.
HasEnvConfig env =>
PackageName -> String -> RIO env (Path Abs File)
tixFilePath (Package -> PackageName
packageName Package
package) (Text -> String
T.unpack Text
testName)
    let report :: StyleDoc
report = [StyleDoc] -> StyleDoc
fillSep
          [ String -> StyleDoc
flow String
"coverage report for"
          , forall a. IsString a => String -> a
fromString String
pkgName' forall a. Semigroup a => a -> a -> a
<> StyleDoc
"'s"
          , StyleDoc
"test-suite"
          , forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ String
"\"" forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
testName forall a. Semigroup a => a -> a -> a
<> String
"\""
          ]
        reportHtml :: Text
reportHtml =
             Text
"coverage report for"
          forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
pkgName'
          forall a. Semigroup a => a -> a -> a
<> Text
"'s test-suite \""
          forall a. Semigroup a => a -> a -> a
<> Text
testName
          forall a. Semigroup a => a -> a -> a
<> Text
"\""
        reportDir :: Path Abs Dir
reportDir = forall b t. Path b t -> Path b Dir
parent Path Abs File
tixSrc
    case Either Text (Maybe [String])
eincludeName of
      Left Text
err -> forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> Utf8Builder -> m ()
generateHpcErrorReport Path Abs Dir
reportDir (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"
                forall a. a -> [a] -> [a]
: forall a. a -> [a] -> [a]
L.intersperse String
"--include" (forall a b. (a -> b) -> [a] -> [b]
map (forall a. [a] -> [a] -> [a]
++ String
":") [String]
includeNames)
        Maybe (Path Abs File)
mreportPath <-
          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
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (Path Abs File)
mreportPath (forall env.
HasTerm env =>
StyleDoc -> StyleDoc -> StyleDoc -> RIO env ()
displayReportPath StyleDoc
"The" StyleDoc
report forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> StyleDoc
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.

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

      Path Rel Dir
hpcRelDir <- forall (m :: * -> *) env.
(MonadThrow m, MonadReader env m, HasEnvConfig env) =>
m (Path Rel Dir)
hpcRelativeDir
      -- Compute arguments used for both "hpc markup" and "hpc report".

      [Path Abs Dir]
pkgDirs <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasBuildConfig env => Lens' env BuildConfig
buildConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to (forall a b. (a -> b) -> [a] -> [b]
map ProjectPackage -> Path Abs Dir
ppRoot forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
Map.elems forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMWanted -> Map PackageName ProjectPackage
smwProject forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildConfig -> SMWanted
bcSMWanted)
      let args :: [String]
args =
            -- Use index files from all packages (allows cross-package coverage results).

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

            [String
"--hpcdir", forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Rel Dir
hpcRelDir, String
"--reset-hpcdirs"]
      forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
        [ StyleDoc
"Generating"
        , StyleDoc
report forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
        ]
      [ByteString]
outputLines <- forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Bool) -> ByteString -> ByteString
S8.filter (forall a. Eq a => a -> a -> Bool
/= Char
'\r')) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
S8.lines forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
String -> [String] -> (ProcessConfig () () () -> m a) -> m a
proc String
"hpc"
        ( String
"report"
        forall a. a -> [a] -> [a]
: forall b t. Path b t -> String
toFilePath Path Abs File
tixSrc
        forall a. a -> [a] -> [a]
: ([String]
args forall a. [a] -> [a] -> [a]
++ [String]
extraReportArgs)
        )
        forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ByteString, ByteString)
readProcess_
      if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (ByteString
"(0/0)" `S8.isSuffixOf`) [ByteString]
outputLines
        then do
          let msgHtml :: Utf8Builder
msgHtml =
                   Utf8Builder
"Error: [S-6829]\n\
                   \The "
                forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
reportHtml
                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."
          forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyError forall a b. (a -> b) -> a -> b
$
            StyleDoc
"[S-6829]"
            forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
            forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
                 [ StyleDoc
"The"
                 , StyleDoc
report
                 , String -> StyleDoc
flow String
"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."
                 ]
          forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> Utf8Builder -> m ()
generateHpcErrorReport Path Abs Dir
reportDir Utf8Builder
msgHtml
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        else do
          let reportPath :: Path Abs File
reportPath = Path Abs Dir
reportDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileHpcIndexHtml
          -- Print output, stripping @\r@ characters because Windows.

          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ByteString]
outputLines (forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Utf8Builder
displayBytesUtf8)
          -- Generate the markup.

          forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
String -> [String] -> (ProcessConfig () () () -> m a) -> m a
proc String
"hpc"
            ( String
"markup"
            forall a. a -> [a] -> [a]
: forall b t. Path b t -> String
toFilePath Path Abs File
tixSrc
            forall a. a -> [a] -> [a]
: (String
"--destdir=" forall a. [a] -> [a] -> [a]
++ forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
reportDir)
            forall a. a -> [a] -> [a]
: ([String]
args forall a. [a] -> [a] -> [a]
++ [String]
extraMarkupArgs)
            )
            forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ByteString, ByteString)
readProcess_
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just Path Abs File
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
  [Path Abs File]
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 -> Bool
hroptsAll HpcReportOpts
opts) Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
targetNames
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    else do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HpcReportOpts -> Bool
hroptsAll HpcReportOpts
opts Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
targetNames)) forall a b. (a -> b) -> a -> b
$
        forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
          forall a b. (a -> b) -> a -> b
$ StyleDoc
"Since"
          forall a. a -> [a] -> [a]
: Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"--all"
          forall a. a -> [a] -> [a]
: String -> StyleDoc
flow String
"is used, it is redundant to specify these targets:"
          forall a. a -> [a] -> [a]
: forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList (forall a. a -> Maybe a
Just Style
Target) Bool
False
              (forall a b. (a -> b) -> [a] -> [b]
map (forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) [Text]
targetNames :: [StyleDoc])
      Map PackageName Target
targets <-
        forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to EnvConfig -> SourceMap
envConfigSourceMapforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to SourceMap -> SMTargets
smTargetsforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to SMTargets -> Map PackageName Target
smtTargets
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName Target
targets) forall a b. (a -> b) -> a -> b
$ \(PackageName
name, Target
target) ->
        case Target
target of
          TargetAll PackageType
PTDependency -> forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO forall a b. (a -> b) -> a -> b
$ PackageName -> CoveragePrettyException
NotLocalPackage PackageName
name
          TargetComps Set NamedComponent
comps -> do
            Path Abs Dir
pkgPath <- forall env.
HasEnvConfig env =>
PackageName -> RIO env (Path Abs Dir)
hpcPkgPath PackageName
name
            forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set NamedComponent
comps) forall a b. (a -> b) -> a -> b
$
              \case
                CTest Text
testName -> (Path Abs Dir
pkgPath </>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                  forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile
                    (  Text -> String
T.unpack Text
testName
                    forall a. [a] -> [a] -> [a]
++ String
"/"
                    forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
testName
                    forall a. [a] -> [a] -> [a]
++ String
".tix"
                    )
                NamedComponent
_ -> forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO forall a b. (a -> b) -> a -> b
$ PackageName -> CoveragePrettyException
NonTestSuiteTarget PackageName
name
          TargetAll PackageType
PTProject -> do
            Path Abs Dir
pkgPath <- forall env.
HasEnvConfig env =>
PackageName -> RIO env (Path Abs Dir)
hpcPkgPath PackageName
name
            Bool
exists <- forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist Path Abs Dir
pkgPath
            if Bool
exists
              then do
                ([Path Abs Dir]
dirs, [Path Abs File]
_) <- forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
pkgPath
                forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Path Abs Dir]
dirs forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
dir -> do
                  ([Path Abs Dir]
_, [Path Abs File]
files) <- forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
dir
                  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. (a -> Bool) -> [a] -> [a]
filter ((String
".tix" `L.isSuffixOf`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> String
toFilePath) [Path Abs File]
files)
              else forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  [Path Abs File]
tixPaths <- (forall a. [a] -> [a] -> [a]
++ [Path Abs File]
targetTixFiles) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *). MonadIO m => String -> m (Path Abs File)
resolveFile' forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) [Text]
tixFiles
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Path Abs File]
tixPaths) forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO CoveragePrettyException
NoTargetsOrTixSpecified
  Path Abs Dir
outputDir <- forall env. HasEnvConfig env => RIO env (Path Abs Dir)
hpcReportDir
  Path Abs Dir
reportDir <- case HpcReportOpts -> Maybe String
hroptsDestDir HpcReportOpts
opts of
    Maybe String
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs Dir
outputDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirCombined forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirCustom)
    Just String
destDir -> do
      Path Abs Dir
dest <- forall (m :: * -> *). MonadIO m => String -> m (Path Abs Dir)
resolveDir' String
destDir
      forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
dest
      forall (f :: * -> *) a. Applicative f => a -> f a
pure Path Abs Dir
dest
  let report :: StyleDoc
report = String -> StyleDoc
flow String
"combined report"
      reportHtml :: Text
reportHtml = Text
"combined report"
  Maybe (Path Abs File)
mreportPath <- 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]
tixPaths
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (Path Abs File)
mreportPath forall a b. (a -> b) -> a -> b
$ \Path Abs File
reportPath ->
    if HpcReportOpts -> Bool
hroptsOpenBrowser HpcReportOpts
opts
      then do
        forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo forall a b. (a -> b) -> a -> b
$ StyleDoc
"Opening" StyleDoc -> StyleDoc -> StyleDoc
<+> forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
reportPath StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc
"in the browser."
        forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Bool
openBrowser (forall b t. Path b t -> String
toFilePath Path Abs File
reportPath)
      else forall env.
HasTerm env =>
StyleDoc -> StyleDoc -> StyleDoc -> RIO env ()
displayReportPath StyleDoc
"The" StyleDoc
report (forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
reportPath)

generateHpcUnifiedReport :: HasEnvConfig env => RIO env ()
generateHpcUnifiedReport :: forall env. HasEnvConfig env => RIO env ()
generateHpcUnifiedReport = do
  Path Abs Dir
outputDir <- forall env. HasEnvConfig env => RIO env (Path Abs Dir)
hpcReportDir
  forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
outputDir
  ([Path Abs Dir]
dirs, [Path Abs File]
_) <- forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
outputDir
  [Path Abs File]
tixFiles0 <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall a. (a -> Bool) -> [a] -> [a]
filter ((String
"combined" /=) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall loc. Path loc Dir -> String
dirnameString) [Path Abs Dir]
dirs) forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
dir -> do
    ([Path Abs Dir]
dirs', [Path Abs File]
_) <- forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
dir
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Path Abs Dir]
dirs' forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
dir' -> do
      ([Path Abs Dir]
_, [Path Abs File]
files) <- forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
dir'
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. (a -> Bool) -> [a] -> [a]
filter ((String
".tix" `L.isSuffixOf`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> String
toFilePath) [Path Abs File]
files)
  [Path Abs File]
extraTixFiles <- forall env. HasEnvConfig env => RIO env [Path Abs File]
findExtraTixFiles
  let tixFiles :: [Path Abs File]
tixFiles = [Path Abs File]
tixFiles0  forall a. [a] -> [a] -> [a]
++ [Path Abs File]
extraTixFiles
      reportDir :: Path Abs Dir
reportDir = Path Abs Dir
outputDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirCombined 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 forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Path Abs File]
tixFiles
    then forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyInfoL
      [ String -> StyleDoc
flow String
"No tix files found in"
      , forall a. Pretty a => a -> StyleDoc
pretty Path Abs Dir
outputDir forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
      , String -> StyleDoc
flow String
"so not generating a unified coverage report."
      ]
    else do
      let report :: StyleDoc
report = String -> StyleDoc
flow String
"unified report"
          reportHtml :: Text
reportHtml = Text
"unified report"
      Maybe (Path Abs File)
mreportPath <- 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
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (Path Abs File)
mreportPath (forall env.
HasTerm env =>
StyleDoc -> StyleDoc -> StyleDoc -> RIO env ()
displayReportPath StyleDoc
"The" StyleDoc
report forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> StyleDoc
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
  ([String]
errs, Tix
tix) <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Tix] -> ([String], Tix)
unionTixes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Tix -> Tix
removeExeModules) (forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM forall env b. HasTerm env => Path b File -> RIO env (Maybe Tix)
readTixOrLog [Path Abs File]
tixFiles)
  forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Using the following tix files: " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (forall a. Show a => a -> String
show [Path Abs File]
tixFiles)
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
errs) forall a b. (a -> b) -> a -> b
$
    forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyWarn forall a b. (a -> b) -> a -> b
$
      [StyleDoc] -> StyleDoc
fillSep
         [ String -> StyleDoc
flow String
"The following modules are left out of the"
         , StyleDoc
report
         , String -> StyleDoc
flow String
"due to version mismatches:"
         ]
    forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList (forall a b. (a -> b) -> [a] -> [b]
map forall a. IsString a => String -> a
fromString [String]
errs :: [StyleDoc])
  Path Abs File
tixDest <- (Path Abs Dir
reportDir </>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile (forall loc. Path loc Dir -> String
dirnameString Path Abs Dir
reportDir forall a. [a] -> [a] -> [a]
++ String
".tix")
  forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (forall b t. Path b t -> Path b Dir
parent Path Abs File
tixDest)
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> Tix -> IO ()
writeTix (forall b t. Path b t -> String
toFilePath Path Abs File
tixDest) Tix
tix
  forall env.
HasEnvConfig env =>
Path Abs File
-> Path Abs Dir
-> StyleDoc
-> Text
-> [String]
-> [String]
-> RIO env (Maybe (Path Abs File))
generateHpcReportInternal Path Abs File
tixDest Path Abs Dir
reportDir StyleDoc
report Text
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
  Maybe Tix
mtix <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO (Maybe Tix)
readTix (forall b t. Path b t -> String
toFilePath Path b File
path)) forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
errorCall -> do
    forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyError forall a b. (a -> b) -> a -> b
$
      StyleDoc
"[S-3521]"
      forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"Error while reading tix:"
      forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
string (forall e. Exception e => e -> String
displayException SomeException
errorCall)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing Maybe Tix
mtix) forall a b. (a -> b) -> a -> b
$
    forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyError forall a b. (a -> b) -> a -> b
$
      StyleDoc
"[S-7786]"
      forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
      forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
           [ String -> StyleDoc
flow String
"Failed to read tix file"
           , forall a. Pretty a => a -> StyleDoc
pretty Path b File
path forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
           ]
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Tix
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 (forall a. (a -> Bool) -> [a] -> [a]
filter (\(TixModule String
name Hash
_ Int
_ [Integer]
_) -> Char
'/' 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 = (forall k a. Map k a -> [k]
Map.keys Map String ()
errs, [TixModule] -> Tix
Tix (forall k a. Map k a -> [a]
Map.elems Map String TixModule
outputs))
 where
  (Map String ()
errs, Map String TixModule
outputs) = forall a b c k. (a -> Either b c) -> Map k a -> (Map k b, Map k c)
Map.mapEither forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith forall {a} {a}.
Either a TixModule -> Either a TixModule -> Either () TixModule
merge forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Tix -> Map String (Either a TixModule)
toMap [Tix]
tixes
  toMap :: Tix -> Map String (Either a TixModule)
toMap (Tix [TixModule]
ms) = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall a b. (a -> b) -> [a] -> [b]
map (\x :: TixModule
x@(TixModule String
k Hash
_ Int
_ [Integer]
_) -> (String
k, 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 forall a. Eq a => a -> a -> Bool
== Hash
hash2 Bool -> Bool -> Bool
&& Int
len1 forall a. Eq a => a -> a -> Bool
== Int
len2 = forall a b. b -> Either a b
Right (String -> Hash -> Int -> [Integer] -> TixModule
TixModule String
k Hash
hash1 Int
len1 (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. Num a => a -> a -> a
(+) [Integer]
tix1 [Integer]
tix2))
  merge Either a TixModule
_ Either a TixModule
_ = forall a b. a -> Either a b
Left ()

generateHpcMarkupIndex :: HasEnvConfig env => RIO env ()
generateHpcMarkupIndex :: forall env. HasEnvConfig env => RIO env ()
generateHpcMarkupIndex = do
  Path Abs Dir
outputDir <- forall env. HasEnvConfig env => RIO env (Path Abs Dir)
hpcReportDir
  let outputFile :: Path Abs File
outputFile = Path Abs Dir
outputDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileIndexHtml
  forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
outputDir
  ([Path Abs Dir]
dirs, [Path Abs File]
_) <- forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
outputDir
  [Text]
rows <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. [Maybe a] -> [a]
catMaybes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Path Abs Dir]
dirs forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
dir -> do
    ([Path Abs Dir]
subdirs, [Path Abs File]
_) <- forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
dir
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Path Abs Dir]
subdirs forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
subdir -> do
      let indexPath :: Path Abs File
indexPath = Path Abs Dir
subdir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileHpcIndexHtml
      Bool
exists' <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
indexPath
      if Bool -> Bool
not Bool
exists' then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing else do
        Path Rel File
relPath <- forall (m :: * -> *) b t.
MonadThrow m =>
Path b Dir -> Path b t -> m (Path Rel t)
stripProperPrefix Path Abs Dir
outputDir Path Abs File
indexPath
        let package :: Path Rel Dir
package = forall b. Path b Dir -> Path Rel Dir
dirname Path Abs Dir
dir
            testsuite :: Path Rel Dir
testsuite = forall b. Path b Dir -> Path Rel Dir
dirname Path Abs Dir
subdir
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
          [ Text
"<tr><td>"
          , forall b t. Path b t -> Text
pathToHtml Path Rel Dir
package
          , Text
"</td><td><a href=\""
          , forall b t. Path b t -> Text
pathToHtml Path Rel File
relPath
          , Text
"\">"
          , forall b t. Path b t -> Text
pathToHtml Path Rel Dir
testsuite
          , Text
"</a></td></tr>"
          ]
  forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic Path Abs File
outputFile forall a b. (a -> b) -> a -> b
$
       Builder
"<html><head><meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\">"
    forall a. Semigroup a => a -> a -> a
<>
    -- Part of the css from HPC's output HTML

       Builder
"<style type=\"text/css\">"
    forall a. Semigroup a => a -> a -> a
<> Builder
"table.dashboard { border-collapse: collapse; border: solid 1px black }"
    forall a. Semigroup a => a -> a -> a
<> Builder
".dashboard td { border: solid 1px black }"
    forall a. Semigroup a => a -> a -> a
<> Builder
".dashboard th { border: solid 1px black }"
    forall a. Semigroup a => a -> a -> a
<> Builder
"</style>"
    forall a. Semigroup a => a -> a -> a
<> Builder
"</head>"
    forall a. Semigroup a => a -> a -> a
<> Builder
"<body>"
    forall a. Semigroup a => a -> a -> a
<> ( if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
rows
           then
                Builder
"<b>No hpc_index.html files found in \""
             forall a. Semigroup a => a -> a -> a
<> Text -> Builder
encodeUtf8Builder (forall b t. Path b t -> Text
pathToHtml Path Abs Dir
outputDir)
             forall a. Semigroup a => a -> a -> a
<> Builder
"\".</b>"
           else
                Builder
"<table class=\"dashboard\" width=\"100%\" border=\"1\"><tbody>"
             forall a. Semigroup a => a -> a -> a
<> Builder
"<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>"
             forall a. Semigroup a => a -> a -> a
<> Builder
"<tr><th>Package</th><th>TestSuite</th><th>Modification Time</th></tr>"
             forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Text -> Builder
encodeUtf8Builder [Text]
rows
             forall a. Semigroup a => a -> a -> a
<> Builder
"</tbody></table>"
       )
    forall a. Semigroup a => a -> a -> a
<> Builder
"</body></html>"
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
rows) forall a b. (a -> b) -> a -> b
$
    forall env.
HasTerm env =>
StyleDoc -> StyleDoc -> StyleDoc -> RIO env ()
displayReportPath
      StyleDoc
"\nAn" StyleDoc
"index of the generated HTML coverage reports"
      (forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
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
  forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
dir
  let fp :: String
fp = forall b t. Path b t -> String
toFilePath (Path Abs Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileHpcIndexHtml)
  forall (m :: * -> *). MonadIO m => String -> Utf8Builder -> m ()
writeFileUtf8Builder String
fp forall a b. (a -> b) -> a -> b
$
       Utf8Builder
"<html><head><meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\"></head><body>"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"<h1>HPC Report Generation Error</h1>"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"<p>"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
err
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"</p>"
    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 (forall a. Eq a => a -> a -> Bool
==Char
'/') forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
sanitize forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
htmlEscape 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 = forall a. (a -> Bool) -> [a] -> [a]
L.dropWhileEnd Char -> Bool
isPathSeparator forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> String
toFilePath forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
internalLibs Text
field = do
  Path Abs Dir
distDir <- forall (m :: * -> *) env.
(MonadThrow m, MonadReader env m, HasEnvConfig env) =>
Path Abs Dir -> m (Path Abs Dir)
distDirFromDir Path Abs Dir
pkgDir
  let inplaceDir :: Path Abs Dir
inplaceDir = Path Abs Dir
distDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirPackageConfInplace
      pkgIdStr :: String
pkgIdStr = PackageIdentifier -> String
packageIdentifierString PackageIdentifier
pkgId
      notFoundErr :: RIO env (Either Text b)
notFoundErr = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Failed to find package key for " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
pkgIdStr
      extractField :: Path b t -> RIO env (Either Text Text)
extractField Path b t
path = do
        Text
contents <- forall (m :: * -> *). MonadIO m => String -> m Text
readFileUtf8 (forall b t. Path b t -> String
toFilePath Path b t
path)
        case forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum (forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text -> Maybe Text
T.stripPrefix (Text
field forall a. Semigroup a => a -> a -> a
<> Text
": ")) (Text -> [Text]
T.lines Text
contents)) of
          Just Text
result -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text -> Text
T.strip Text
result
          Maybe Text
Nothing -> forall {b}. RIO env (Either Text b)
notFoundErr
  Version
cabalVer <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasCompiler env => SimpleGetter env Version
cabalVersionL
  if Version
cabalVer forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
1, Int
24]
    then do
      -- here we don't need to handle internal libs

      Path Abs File
path <- (Path Abs Dir
inplaceDir </>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile (String
pkgIdStr forall a. [a] -> [a] -> [a]
++ String
"-inplace.conf")
      forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$
           Utf8Builder
"Parsing config in Cabal < 1.24 location: "
        forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (forall b t. Path b t -> String
toFilePath Path Abs File
path)
      Bool
exists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
path
      if Bool
exists then forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {b} {t}. Path b t -> RIO env (Either Text Text)
extractField Path Abs File
path else forall {b}. RIO env (Either Text b)
notFoundErr
    else do
      -- With Cabal-1.24, it's in a different location.

      forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Scanning " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (forall b t. Path b t -> String
toFilePath Path Abs Dir
inplaceDir) forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" for files matching " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString String
pkgIdStr
      ([Path Abs Dir]
_, [Path Abs File]
files) <- forall (m :: * -> *) a.
MonadUnliftIO m =>
(IOException -> m a) -> m a -> m a
handleIO (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [])) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
inplaceDir
      forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> Utf8Builder
displayShow [Path Abs File]
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 :: Path b File -> Text
toFilename = String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> String
toFilePath forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. Path b File -> Path Rel File
filename
          -- strip known prefix and suffix from the found files to determine only the conf files

          stripKnown :: Text -> Maybe Text
stripKnown =  Text -> Text -> Maybe Text
T.stripSuffix Text
".conf" forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Text -> Text -> Maybe Text
T.stripPrefix (String -> Text
T.pack (String
pkgIdStr forall a. [a] -> [a] -> [a]
++ String
"-"))
          stripped :: [(Text, Path Abs File)]
stripped = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\Path Abs File
file -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,Path Abs File
file) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Text
stripKnown forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {b}. Path b File -> Text
toFilename forall a b. (a -> b) -> a -> b
$ Path Abs File
file) [Path Abs File]
files
          -- which component could have generated each of these conf files

          stripHash :: Text -> Text
stripHash Text
n = let z :: Text
z = (Char -> Bool) -> Text -> Text
T.dropWhile (forall a. Eq a => a -> a -> Bool
/= Char
'-') Text
n in if Text -> Bool
T.null Text
z then Text
"" else Text -> Text
T.tail Text
z
          matchedComponents :: [(Text, [Path Abs File])]
matchedComponents = forall a b. (a -> b) -> [a] -> [b]
map (\(Text
n, Path Abs File
f) -> (Text -> Text
stripHash Text
n, [Path Abs File
f])) [(Text, Path Abs File)]
stripped
          byComponents :: Map Text [Path Abs File]
byComponents = forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys (forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. [a] -> [a] -> [a]
(++) [(Text, [Path Abs File])]
matchedComponents) forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> Set a -> Set a
Set.insert Text
"" Set Text
internalLibs
      forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> Utf8Builder
displayShow Map Text [Path Abs File]
byComponents
      if forall k a. Map k a -> Bool
Map.null forall a b. (a -> b) -> a -> b
$ forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (\[Path Abs File]
fs -> forall (t :: * -> *) a. Foldable t => t a -> Int
length [Path Abs File]
fs forall a. Ord a => a -> a -> Bool
> Int
1) Map Text [Path Abs File]
byComponents
      then case forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems Map Text [Path Abs File]
byComponents of
        [] -> forall {b}. RIO env (Either Text b)
notFoundErr
        -- for each of these files, we need to extract the requested field

        [Path Abs File]
paths -> do
          ([Text]
errors, [Text]
keys) <-  forall a b. [Either a b] -> ([a], [b])
partitionEithers forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {b} {t}. Path b t -> RIO env (Either Text Text)
extractField [Path Abs File]
paths
          case [Text]
errors of
            (Text
a:[Text]
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Text
a -- the first error only, since they're repeated anyway

            [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right [Text]
keys
      else
        forall (f :: * -> *) a. Applicative f => a -> f a
pure
          forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left
          forall a b. (a -> b) -> a -> b
$    Text
"Multiple files matching "
            forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (String
pkgIdStr forall a. [a] -> [a] -> [a]
++ String
"-*.conf")
            forall a. Semigroup a => a -> a -> a
<> Text
" found in "
            forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall b t. Path b t -> String
toFilePath Path Abs Dir
inplaceDir)
            forall a. Semigroup a => a -> a -> a
<> Text
". Maybe try 'stack clean' on this package?"

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 =
  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 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
  Path Abs Dir
outputDir <- forall env. HasEnvConfig env => RIO env (Path Abs Dir)
hpcReportDir
  let dir :: Path Abs Dir
dir = Path Abs Dir
outputDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirExtraTixFiles
  Bool
dirExists <- forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist Path Abs Dir
dir
  if Bool
dirExists
    then do
      ([Path Abs Dir]
_, [Path Abs File]
files) <- forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
dir
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter ((String
".tix" `L.isSuffixOf`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> String
toFilePath) [Path Abs File]
files
    else forall (f :: * -> *) a. Applicative f => a -> f a
pure []