{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TupleSections         #-}

-- | Generate HPC (Haskell Program Coverage) reports

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

import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as BL
import qualified Data.List as L
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import           Distribution.Version ( mkVersion )
import           Path
import           Path.Extra ( toFilePathNoTrailingSep )
import           Path.IO
import           RIO.Process
import           Stack.Build.Target
import           Stack.Constants
import           Stack.Constants.Config
import           Stack.Package
import           Stack.Prelude
import           Stack.Types.Compiler
import           Stack.Types.Config
import           Stack.Types.NamedComponent
import           Stack.Types.Package
import           Stack.Types.SourceMap
import           System.FilePath ( isPathSeparator )
import           Trace.Hpc.Tix
import           Web.Browser (openBrowser)

-- | Type representing exceptions thrown by functions exported by the

-- "Stack.Coverage" module.

data CoverageException
    = NonTestSuiteTarget PackageName
    | NoTargetsOrTixSpecified
    | NotLocalPackage PackageName
    deriving (Int -> CoverageException -> ShowS
[CoverageException] -> ShowS
CoverageException -> String
(Int -> CoverageException -> ShowS)
-> (CoverageException -> String)
-> ([CoverageException] -> ShowS)
-> Show CoverageException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CoverageException -> ShowS
showsPrec :: Int -> CoverageException -> ShowS
$cshow :: CoverageException -> String
show :: CoverageException -> String
$cshowList :: [CoverageException] -> ShowS
showList :: [CoverageException] -> ShowS
Show, Typeable)

instance Exception CoverageException where
    displayException :: CoverageException -> String
displayException (NonTestSuiteTarget PackageName
name) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Error: [S-6361]\n"
        , String
"Can't specify anything except test-suites as hpc report targets ("
        , PackageName -> String
packageNameString PackageName
name
        , String
") is used with a non test-suite target."
        ]
    displayException CoverageException
NoTargetsOrTixSpecified =
        String
"Error: [S-2321]\n"
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Not generating combined report, because no targets or tix files \
           \are specified."
    displayException (NotLocalPackage PackageName
name) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Error: [S-9975]"
        , String
"Expected a local package, but "
        , PackageName -> String
packageNameString PackageName
name
        , String
" is either an extra-dep or in the snapshot."
        ]

-- | 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 <- RIO env (Path Abs Dir)
forall env. HasEnvConfig env => RIO env (Path Abs Dir)
hpcReportDir
    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 Dir -> IO ()
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 <- Path Abs File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
tixSrc
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
        Path Abs File
tixDest <- PackageName -> String -> RIO env (Path Abs File)
forall env.
HasEnvConfig env =>
PackageName -> String -> RIO env (Path Abs File)
tixFilePath PackageName
pkgName' String
testName
        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
tixDest)
        Path Abs Dir -> RIO env ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (Path Abs File -> Path Abs Dir
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 <- Path Abs File -> RIO env (Maybe Tix)
forall env b. HasLogFunc env => Path b File -> RIO env (Maybe Tix)
readTixOrLog Path Abs File
tixSrc
        case Maybe Tix
mtix of
            Maybe Tix
Nothing -> 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
$
                Utf8Builder
"Error: [S-2887]\n" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                Utf8Builder
"Failed to read " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
tixSrc)
            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
    Path Abs Dir
outputDir <- RIO env (Path Abs Dir)
forall env. HasEnvConfig env => RIO env (Path Abs Dir)
hpcReportDir
    Path Rel Dir
pkgNameRel <- String -> RIO env (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir (PackageName -> String
packageNameString PackageName
pkgName')
    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
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 <- PackageName -> RIO env (Path Abs Dir)
forall env.
HasEnvConfig env =>
PackageName -> RIO env (Path Abs Dir)
hpcPkgPath PackageName
pkgName'
    Path Rel File
tixRel <- 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")
    Path Abs File -> RIO env (Path Abs File)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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
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 <- Getting ActualCompiler env ActualCompiler -> RIO env ActualCompiler
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ActualCompiler env ActualCompiler
forall env. HasSourceMap env => SimpleGetter env ActualCompiler
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 pkgName' :: Text
pkgName' = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString (Package -> PackageName
packageName Package
package)
        pkgId :: String
pkgId = PackageIdentifier -> String
packageIdentifierString (Package -> PackageIdentifier
packageIdentifier 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 Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
7, Int
10] 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] -> 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
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
&& Set Text -> Bool
forall a. Set a -> Bool
Set.null Set Text
internalLibs 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
            -- 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 Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
8, Int
0] then Text
"id" else Text
"key"
            Either Text [Text]
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) Set Text
internalLibs Text
hpcNameField
            case Either Text [Text]
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
    [Text] -> (Text -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Text]
tests ((Text -> RIO env ()) -> RIO env ())
-> (Text -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \Text
testName -> do
        Path Abs File
tixSrc <- PackageName -> String -> RIO env (Path Abs File)
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 :: Text
report = Text
"coverage report for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
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 Dir
reportDir = Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
tixSrc
        case Either Text (Maybe [String])
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
n -> String
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":") [String]
includeNames)
                Maybe (Path Abs File)
mreportPath <- Path Abs File
-> Path Abs Dir
-> Text
-> [String]
-> [String]
-> RIO env (Maybe (Path Abs File))
forall env.
HasEnvConfig env =>
Path Abs File
-> Path Abs Dir
-> Text
-> [String]
-> [String]
-> RIO env (Maybe (Path Abs File))
generateHpcReportInternal Path Abs File
tixSrc Path Abs Dir
reportDir Text
report [String]
extraArgs [String]
extraArgs
                Maybe (Path Abs File)
-> (Path Abs File -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (Path Abs File)
mreportPath (StyleDoc -> Text -> StyleDoc -> RIO env ()
forall env.
HasTerm env =>
StyleDoc -> Text -> StyleDoc -> RIO env ()
displayReportPath StyleDoc
"The" Text
report (StyleDoc -> RIO env ())
-> (Path Abs File -> StyleDoc) -> Path Abs File -> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty)

generateHpcReportInternal :: HasEnvConfig env
                          => Path Abs File -> Path Abs Dir -> Text -> [String] -> [String]
                          -> RIO env (Maybe (Path Abs File))
generateHpcReportInternal :: forall env.
HasEnvConfig env =>
Path Abs File
-> Path Abs Dir
-> Text
-> [String]
-> [String]
-> RIO env (Maybe (Path Abs File))
generateHpcReportInternal Path Abs File
tixSrc Path Abs Dir
reportDir Text
report [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 <- Path Abs File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
tixSrc
    if Bool -> Bool
not Bool
tixFileExists
        then 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
$
                 Utf8Builder
"Error: [S-4634]\n" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                 Utf8Builder
"Didn't find .tix for " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                 Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
report Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                 Utf8Builder
" - expected to find it at " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                 String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
tixSrc) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                 Utf8Builder
"."
            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
        else (RIO env (Maybe (Path Abs File))
-> (ProcessException -> RIO env (Maybe (Path Abs File)))
-> RIO env (Maybe (Path Abs File))
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`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) (RIO env (Maybe (Path Abs File))
 -> RIO env (Maybe (Path Abs File)))
-> RIO env (Maybe (Path Abs File))
-> RIO env (Maybe (Path Abs File))
forall a b. (a -> b) -> a -> b
$
             (RIO env (Maybe (Path Abs File))
-> RIO env () -> RIO env (Maybe (Path Abs File))
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`onException`
                 Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError
                   (Utf8Builder
"Error: [S-8215]\n" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                    Utf8Builder
"Error occurred while producing " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                    Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
report)) (RIO env (Maybe (Path Abs File))
 -> RIO env (Maybe (Path Abs File)))
-> RIO env (Maybe (Path Abs File))
-> RIO env (Maybe (Path Abs File))
forall a b. (a -> b) -> a -> b
$ do
            -- Directories for .mix files.

            Path Rel Dir
hpcRelDir <- RIO env (Path Rel Dir)
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 <- Getting [Path Abs Dir] env [Path Abs Dir] -> RIO env [Path Abs Dir]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting [Path Abs Dir] env [Path Abs Dir]
 -> RIO env [Path Abs Dir])
-> Getting [Path Abs Dir] env [Path Abs Dir]
-> RIO env [Path Abs Dir]
forall a b. (a -> b) -> a -> b
$ (BuildConfig -> Const [Path Abs Dir] BuildConfig)
-> env -> Const [Path Abs Dir] env
forall env. HasBuildConfig env => Lens' env BuildConfig
Lens' env BuildConfig
buildConfigL((BuildConfig -> Const [Path Abs Dir] BuildConfig)
 -> env -> Const [Path Abs Dir] env)
-> (([Path Abs Dir] -> Const [Path Abs Dir] [Path Abs Dir])
    -> BuildConfig -> Const [Path Abs Dir] BuildConfig)
-> Getting [Path Abs Dir] env [Path Abs Dir]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(BuildConfig -> [Path Abs Dir])
-> SimpleGetter BuildConfig [Path Abs Dir]
forall s a. (s -> a) -> SimpleGetter s a
to ((ProjectPackage -> Path Abs Dir)
-> [ProjectPackage] -> [Path Abs Dir]
forall a b. (a -> b) -> [a] -> [b]
map ProjectPackage -> Path Abs Dir
ppRoot ([ProjectPackage] -> [Path Abs Dir])
-> (BuildConfig -> [ProjectPackage])
-> BuildConfig
-> [Path Abs Dir]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map PackageName ProjectPackage -> [ProjectPackage]
forall k a. Map k a -> [a]
Map.elems (Map PackageName ProjectPackage -> [ProjectPackage])
-> (BuildConfig -> Map PackageName ProjectPackage)
-> BuildConfig
-> [ProjectPackage]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMWanted -> Map PackageName ProjectPackage
smwProject (SMWanted -> Map PackageName ProjectPackage)
-> (BuildConfig -> SMWanted)
-> BuildConfig
-> Map PackageName ProjectPackage
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).

                    (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"]
            Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Generating " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
report
            [ByteString]
outputLines <- ((ByteString, ByteString) -> [ByteString])
-> RIO env (ByteString, ByteString) -> RIO env [ByteString]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Bool) -> ByteString -> ByteString
S8.filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r')) ([ByteString] -> [ByteString])
-> ((ByteString, ByteString) -> [ByteString])
-> (ByteString, ByteString)
-> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
S8.lines (ByteString -> [ByteString])
-> ((ByteString, ByteString) -> ByteString)
-> (ByteString, ByteString)
-> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.toStrict (ByteString -> ByteString)
-> ((ByteString, ByteString) -> ByteString)
-> (ByteString, ByteString)
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst) (RIO env (ByteString, ByteString) -> RIO env [ByteString])
-> RIO env (ByteString, ByteString) -> RIO env [ByteString]
forall a b. (a -> b) -> a -> b
$
                String
-> [String]
-> (ProcessConfig () () () -> RIO env (ByteString, ByteString))
-> RIO env (ByteString, ByteString)
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"
                String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
tixSrc
                String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ([String]
args [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
extraReportArgs)
                )
                ProcessConfig () () () -> RIO env (ByteString, ByteString)
forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ByteString, ByteString)
readProcess_
            if (ByteString -> Bool) -> [ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (ByteString
"(0/0)" ByteString -> ByteString -> Bool
`S8.isSuffixOf`) [ByteString]
outputLines
                then do
                    let msg :: Bool -> Utf8Builder
msg Bool
html =
                            Utf8Builder
"Error: [S-6829]\n"Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                            Utf8Builder
"The " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                            Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
report Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                            Utf8Builder
" did not consider any code. One possible cause of this is" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                            Utf8Builder
" if your test-suite builds the library code (see Stack " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                            (if Bool
html then Utf8Builder
"<a href='https://github.com/commercialhaskell/stack/issues/1008'>" else Utf8Builder
"") Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                            Utf8Builder
"issue #1008" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                            (if Bool
html then Utf8Builder
"</a>" else Utf8Builder
"") Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                            Utf8Builder
"). It may also indicate a bug in Stack or" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                            Utf8Builder
" the hpc program. Please report this issue if you think" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                            Utf8Builder
" your coverage report should have meaningful results."
                    Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Bool -> Utf8Builder
msg Bool
False)
                    Path Abs Dir -> Utf8Builder -> RIO env ()
forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> Utf8Builder -> m ()
generateHpcErrorReport Path Abs Dir
reportDir (Bool -> Utf8Builder
msg Bool
True)
                    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
                else do
                    let reportPath :: Path Abs File
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 output, stripping @\r@ characters because Windows.

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

                    RIO env (ByteString, ByteString) -> RIO env ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (RIO env (ByteString, ByteString) -> RIO env ())
-> RIO env (ByteString, ByteString) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ String
-> [String]
-> (ProcessConfig () () () -> RIO env (ByteString, ByteString))
-> RIO env (ByteString, ByteString)
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"
                        String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
tixSrc
                        String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (String
"--destdir=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Path Abs Dir -> String
forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
reportDir)
                        String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ([String]
args [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
extraMarkupArgs)
                        )
                        ProcessConfig () () () -> RIO env (ByteString, ByteString)
forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ByteString, ByteString)
readProcess_
                    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 (Path Abs File -> Maybe (Path Abs File)
forall a. a -> Maybe a
Just Path Abs File
reportPath)

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
(Int -> HpcReportOpts -> ShowS)
-> (HpcReportOpts -> String)
-> ([HpcReportOpts] -> ShowS)
-> Show HpcReportOpts
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HpcReportOpts -> ShowS
showsPrec :: Int -> HpcReportOpts -> ShowS
$cshow :: HpcReportOpts -> String
show :: HpcReportOpts -> String
$cshowList :: [HpcReportOpts] -> ShowS
showList :: [HpcReportOpts] -> ShowS
Show)

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
&& [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 -> Bool
hroptsAll HpcReportOpts
opts 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
$
                 Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Since --all is used, it is redundant to specify these targets: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> [Text] -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow [Text]
targetNames
             Map PackageName Target
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 -> SourceMap) -> SimpleGetter EnvConfig SourceMap
forall s a. (s -> a) -> SimpleGetter s a
to EnvConfig -> SourceMap
envConfigSourceMapGetting (Map PackageName Target) EnvConfig SourceMap
-> ((Map PackageName Target
     -> Const (Map PackageName Target) (Map PackageName Target))
    -> SourceMap -> Const (Map PackageName Target) SourceMap)
-> (Map PackageName Target
    -> Const (Map PackageName Target) (Map PackageName Target))
-> EnvConfig
-> Const (Map PackageName Target) EnvConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(SourceMap -> SMTargets) -> SimpleGetter SourceMap SMTargets
forall s a. (s -> a) -> SimpleGetter s a
to SourceMap -> SMTargets
smTargetsGetting (Map PackageName Target) SourceMap SMTargets
-> ((Map PackageName Target
     -> Const (Map PackageName Target) (Map PackageName Target))
    -> SMTargets -> Const (Map PackageName Target) SMTargets)
-> (Map PackageName Target
    -> Const (Map PackageName Target) (Map PackageName Target))
-> SourceMap
-> Const (Map PackageName Target) SourceMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(SMTargets -> Map PackageName Target)
-> SimpleGetter SMTargets (Map PackageName Target)
forall s a. (s -> a) -> SimpleGetter s a
to SMTargets -> Map PackageName Target
smtTargets
             ([[Path Abs File]] -> [Path Abs File])
-> RIO env [[Path Abs File]] -> RIO env [Path Abs File]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[Path Abs File]] -> [Path Abs File]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (RIO env [[Path Abs File]] -> RIO env [Path Abs File])
-> RIO env [[Path Abs File]] -> RIO env [Path Abs File]
forall a b. (a -> b) -> a -> b
$ [(PackageName, Target)]
-> ((PackageName, Target) -> RIO env [Path Abs File])
-> RIO env [[Path Abs File]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Map PackageName Target -> [(PackageName, Target)]
forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName Target
targets) (((PackageName, Target) -> RIO env [Path Abs File])
 -> RIO env [[Path Abs File]])
-> ((PackageName, Target) -> RIO env [Path Abs File])
-> RIO env [[Path Abs File]]
forall a b. (a -> b) -> a -> b
$ \(PackageName
name, Target
target) ->
                 case Target
target of
                     TargetAll PackageType
PTDependency -> CoverageException -> RIO env [Path Abs File]
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (CoverageException -> RIO env [Path Abs File])
-> CoverageException -> RIO env [Path Abs File]
forall a b. (a -> b) -> a -> b
$ PackageName -> CoverageException
NotLocalPackage PackageName
name
                     TargetComps Set NamedComponent
comps -> do
                         Path Abs Dir
pkgPath <- PackageName -> RIO env (Path Abs Dir)
forall env.
HasEnvConfig env =>
PackageName -> RIO env (Path Abs Dir)
hpcPkgPath PackageName
name
                         [NamedComponent]
-> (NamedComponent -> RIO env (Path Abs File))
-> RIO env [Path Abs File]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Set NamedComponent -> [NamedComponent]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set NamedComponent
comps) ((NamedComponent -> RIO env (Path Abs File))
 -> RIO env [Path Abs File])
-> (NamedComponent -> RIO env (Path Abs File))
-> RIO env [Path Abs File]
forall a b. (a -> b) -> a -> b
$ \NamedComponent
nc ->
                             case NamedComponent
nc of
                                 CTest Text
testName ->
                                     (Path Rel File -> Path Abs File)
-> RIO env (Path Rel File) -> RIO env (Path Abs File)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (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
</>) (RIO env (Path Rel File) -> RIO env (Path Abs File))
-> RIO env (Path Rel File) -> RIO env (Path Abs File)
forall a b. (a -> b) -> a -> b
$ String -> RIO env (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile (Text -> String
T.unpack Text
testName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
testName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".tix")
                                 NamedComponent
_ -> CoverageException -> RIO env (Path Abs File)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (CoverageException -> RIO env (Path Abs File))
-> CoverageException -> RIO env (Path Abs File)
forall a b. (a -> b) -> a -> b
$ PackageName -> CoverageException
NonTestSuiteTarget PackageName
name

                     TargetAll PackageType
PTProject -> do
                         Path Abs Dir
pkgPath <- PackageName -> RIO env (Path Abs Dir)
forall env.
HasEnvConfig env =>
PackageName -> RIO env (Path Abs Dir)
hpcPkgPath PackageName
name
                         Bool
exists <- Path Abs Dir -> RIO env Bool
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]
_) <- 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
pkgPath
                                 ([[Path Abs File]] -> [Path Abs File])
-> RIO env [[Path Abs File]] -> RIO env [Path Abs File]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[Path Abs File]] -> [Path Abs File]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (RIO env [[Path Abs File]] -> RIO env [Path Abs File])
-> RIO env [[Path Abs File]] -> RIO env [Path Abs File]
forall a b. (a -> b) -> a -> b
$ [Path Abs Dir]
-> (Path Abs Dir -> RIO env [Path Abs File])
-> RIO env [[Path Abs File]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Path Abs Dir]
dirs ((Path Abs Dir -> RIO env [Path Abs File])
 -> RIO env [[Path Abs File]])
-> (Path Abs Dir -> RIO env [Path Abs File])
-> RIO env [[Path Abs File]]
forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
dir -> do
                                     ([Path Abs Dir]
_, [Path Abs File]
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
                                     [Path Abs File] -> RIO env [Path Abs File]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Path Abs File -> Bool) -> [Path Abs File] -> [Path Abs File]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String
".tix" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isSuffixOf`) (String -> Bool)
-> (Path Abs File -> String) -> Path Abs File -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> String
forall b t. Path b t -> String
toFilePath) [Path Abs File]
files)
                             else [Path Abs File] -> RIO env [Path Abs File]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    [Path Abs File]
tixPaths <- ([Path Abs File] -> [Path Abs File])
-> RIO env [Path Abs File] -> RIO env [Path Abs File]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\[Path Abs File]
xs -> [Path Abs File]
xs [Path Abs File] -> [Path Abs File] -> [Path Abs File]
forall a. [a] -> [a] -> [a]
++ [Path Abs File]
targetTixFiles) (RIO env [Path Abs File] -> RIO env [Path Abs File])
-> RIO env [Path Abs File] -> RIO env [Path Abs File]
forall a b. (a -> b) -> a -> b
$ (Text -> RIO env (Path Abs File))
-> [Text] -> RIO env [Path Abs File]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (String -> RIO env (Path Abs File)
forall (m :: * -> *). MonadIO m => String -> m (Path Abs File)
resolveFile' (String -> RIO env (Path Abs File))
-> (Text -> String) -> Text -> RIO env (Path Abs File)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) [Text]
tixFiles
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Path Abs File] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Path Abs File]
tixPaths) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ CoverageException -> RIO env ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO CoverageException
NoTargetsOrTixSpecified
    Path Abs Dir
outputDir <- RIO env (Path Abs Dir)
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 -> 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
            Path Abs Dir
dest <- String -> RIO env (Path Abs Dir)
forall (m :: * -> *). MonadIO m => String -> m (Path Abs Dir)
resolveDir' String
destDir
            Path Abs Dir -> RIO env ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
dest
            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
dest
    let report :: Text
report = Text
"combined report"
    Maybe (Path Abs File)
mreportPath <- Text
-> Path Abs Dir
-> [Path Abs File]
-> RIO env (Maybe (Path Abs File))
forall env.
HasEnvConfig env =>
Text
-> Path Abs Dir
-> [Path Abs File]
-> RIO env (Maybe (Path Abs File))
generateUnionReport Text
report Path Abs Dir
reportDir [Path Abs File]
tixPaths
    Maybe (Path Abs File)
-> (Path Abs File -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (Path Abs File)
mreportPath ((Path Abs File -> RIO env ()) -> RIO env ())
-> (Path Abs File -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \Path Abs File
reportPath ->
        if HpcReportOpts -> Bool
hroptsOpenBrowser HpcReportOpts
opts
            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 -> Text -> StyleDoc -> RIO env ()
forall env.
HasTerm env =>
StyleDoc -> Text -> StyleDoc -> RIO env ()
displayReportPath StyleDoc
"The" Text
report (Path Abs File -> StyleDoc
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 <- RIO env (Path Abs Dir)
forall env. HasEnvConfig env => RIO env (Path Abs Dir)
hpcReportDir
    Path Abs Dir -> RIO env ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
outputDir
    ([Path Abs Dir]
dirs, [Path Abs File]
_) <- 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
outputDir
    [Path Abs File]
tixFiles0 <- ([[[Path Abs File]]] -> [Path Abs File])
-> RIO env [[[Path Abs File]]] -> RIO env [Path Abs File]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ([[Path Abs File]] -> [Path Abs File]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Path Abs File]] -> [Path Abs File])
-> ([[[Path Abs File]]] -> [[Path Abs File]])
-> [[[Path Abs File]]]
-> [Path Abs File]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[[Path Abs File]]] -> [[Path Abs File]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) (RIO env [[[Path Abs File]]] -> RIO env [Path Abs File])
-> RIO env [[[Path Abs File]]] -> RIO env [Path Abs File]
forall a b. (a -> b) -> a -> b
$ [Path Abs Dir]
-> (Path Abs Dir -> RIO env [[Path Abs File]])
-> RIO env [[[Path Abs File]]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ((Path Abs Dir -> Bool) -> [Path Abs Dir] -> [Path Abs Dir]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String
"combined" String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/=) (String -> Bool)
-> (Path Abs Dir -> String) -> Path Abs Dir -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs Dir -> String
forall loc. Path loc Dir -> String
dirnameString) [Path Abs Dir]
dirs) ((Path Abs Dir -> RIO env [[Path Abs File]])
 -> RIO env [[[Path Abs File]]])
-> (Path Abs Dir -> RIO env [[Path Abs File]])
-> RIO env [[[Path Abs File]]]
forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
dir -> do
        ([Path Abs Dir]
dirs', [Path Abs File]
_) <- 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
        [Path Abs Dir]
-> (Path Abs Dir -> RIO env [Path Abs File])
-> RIO env [[Path Abs File]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Path Abs Dir]
dirs' ((Path Abs Dir -> RIO env [Path Abs File])
 -> RIO env [[Path Abs File]])
-> (Path Abs Dir -> RIO env [Path Abs File])
-> RIO env [[Path Abs File]]
forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
dir' -> do
            ([Path Abs Dir]
_, [Path Abs File]
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'
            [Path Abs File] -> RIO env [Path Abs File]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Path Abs File -> Bool) -> [Path Abs File] -> [Path Abs File]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String
".tix" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isSuffixOf`) (String -> Bool)
-> (Path Abs File -> String) -> Path Abs File -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> String
forall b t. Path b t -> String
toFilePath) [Path Abs File]
files)
    [Path Abs File]
extraTixFiles <- RIO env [Path Abs File]
forall env. HasEnvConfig env => RIO env [Path Abs File]
findExtraTixFiles
    let tixFiles :: [Path Abs File]
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
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
-- Previously, the test below was:

--

--  if length tixFiles < 2

--      then logInfo $

--          (if null tixFiles then "No tix files" else "Only one tix file") <>

--          " found in " <>

--          fromString (toFilePath outputDir) <>

--          ", so not generating a unified coverage report."

--      else ...

--

-- However, a single *.tix file does not necessarily mean that a unified

-- coverage report is redundant. For example, one package may test the library

-- of another package that does not test its own library. See

-- https://github.com/commercialhaskell/stack/issues/5713

--

-- As an interim solution, a unified coverage report will always be produced

-- even if may be redundant in some circumstances.

    if [Path Abs File] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Path Abs File]
tixFiles
        then Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"No tix files found in " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
            String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath Path Abs Dir
outputDir) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
            Utf8Builder
", so not generating a unified coverage report."
        else do
            let report :: Text
report = Text
"unified report"
            Maybe (Path Abs File)
mreportPath <- Text
-> Path Abs Dir
-> [Path Abs File]
-> RIO env (Maybe (Path Abs File))
forall env.
HasEnvConfig env =>
Text
-> Path Abs Dir
-> [Path Abs File]
-> RIO env (Maybe (Path Abs File))
generateUnionReport Text
report Path Abs Dir
reportDir [Path Abs File]
tixFiles
            Maybe (Path Abs File)
-> (Path Abs File -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (Path Abs File)
mreportPath (StyleDoc -> Text -> StyleDoc -> RIO env ()
forall env.
HasTerm env =>
StyleDoc -> Text -> StyleDoc -> RIO env ()
displayReportPath StyleDoc
"The" Text
report (StyleDoc -> RIO env ())
-> (Path Abs File -> StyleDoc) -> Path Abs File -> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty)

generateUnionReport :: HasEnvConfig env
                    => Text -> Path Abs Dir -> [Path Abs File]
                    -> RIO env (Maybe (Path Abs File))
generateUnionReport :: forall env.
HasEnvConfig env =>
Text
-> Path Abs Dir
-> [Path Abs File]
-> RIO env (Maybe (Path Abs File))
generateUnionReport Text
report Path Abs Dir
reportDir [Path Abs File]
tixFiles = do
    ([String]
errs, Tix
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. HasLogFunc env => Path b File -> RIO env (Maybe Tix)
readTixOrLog [Path Abs File]
tixFiles)
    Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Using the following tix files: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString ([Path Abs File] -> String
forall a. Show a => a -> String
show [Path Abs File]
tixFiles)
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
errs) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
        Utf8Builder
"The following modules are left out of the " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
        Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
report Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
        Utf8Builder
" due to version mismatches: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
        [Utf8Builder] -> Utf8Builder
forall a. Monoid a => [a] -> a
mconcat (Utf8Builder -> [Utf8Builder] -> [Utf8Builder]
forall a. a -> [a] -> [a]
L.intersperse Utf8Builder
", " ((String -> Utf8Builder) -> [String] -> [Utf8Builder]
forall a b. (a -> b) -> [a] -> [b]
map String -> Utf8Builder
forall a. IsString a => String -> a
fromString [String]
errs))
    Path Abs File
tixDest <- (Path Rel File -> Path Abs File)
-> RIO env (Path Rel File) -> RIO env (Path Abs File)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (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
</>) (RIO env (Path Rel File) -> RIO env (Path Abs File))
-> RIO env (Path Rel File) -> RIO env (Path Abs File)
forall a b. (a -> b) -> a -> b
$ String -> RIO env (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile (Path Abs Dir -> String
forall loc. Path loc Dir -> String
dirnameString Path Abs Dir
reportDir String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".tix")
    Path Abs Dir -> RIO env ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
tixDest)
    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
    Path Abs File
-> Path Abs Dir
-> Text
-> [String]
-> [String]
-> RIO env (Maybe (Path Abs File))
forall env.
HasEnvConfig env =>
Path Abs File
-> Path Abs Dir
-> Text
-> [String]
-> [String]
-> RIO env (Maybe (Path Abs File))
generateHpcReportInternal Path Abs File
tixDest Path Abs Dir
reportDir Text
report [] []

readTixOrLog :: HasLogFunc env => Path b File -> RIO env (Maybe Tix)
readTixOrLog :: forall env b. HasLogFunc env => Path b File -> RIO env (Maybe Tix)
readTixOrLog Path b File
path = do
    Maybe Tix
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
        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
$
            Utf8Builder
"Error: [S-3521]\n" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
            Utf8Builder
"Error while reading tix: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
            String -> Utf8Builder
forall a. IsString a => String -> a
fromString (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
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Tix -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Tix
mtix) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
        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
$
            Utf8Builder
"Error: [S-7786]\n" Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
            Utf8Builder
"Failed to read tix file " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
            String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path b File -> String
forall b t. Path b t -> String
toFilePath Path b File
path)
    Maybe Tix -> RIO env (Maybe Tix)
forall a. a -> RIO env a
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 ((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 ()

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

        Builder
"<style type=\"text/css\">" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Builder
"table.dashboard { border-collapse: collapse; border: solid 1px black }" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Builder
".dashboard td { border: solid 1px black }" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Builder
".dashboard th { border: solid 1px black }" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Builder
"</style>" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Builder
"</head>" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Builder
"<body>" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        (if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
rows
            then
                Builder
"<b>No hpc_index.html files found in \"" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
                Text -> Builder
encodeUtf8Builder (Path Abs Dir -> Text
forall b t. Path b t -> Text
pathToHtml Path Abs Dir
outputDir) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
                Builder
"\".</b>"
            else
                Builder
"<table class=\"dashboard\" width=\"100%\" border=\"1\"><tbody>" Builder -> Builder -> Builder
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>" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
                Builder
"<tr><th>Package</th><th>TestSuite</th><th>Modification Time</th></tr>" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
                (Text -> Builder) -> [Text] -> Builder
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Text -> Builder
encodeUtf8Builder [Text]
rows Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
                Builder
"</tbody></table>") Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        Builder
"</body></html>"
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
rows) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
        StyleDoc -> Text -> StyleDoc -> RIO env ()
forall env.
HasTerm env =>
StyleDoc -> Text -> StyleDoc -> RIO env ()
displayReportPath StyleDoc
"\nAn" Text
"index of the generated HTML coverage reports"
            (Path Abs File -> StyleDoc
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
    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
internalLibs Text
field = do
    Path Abs Dir
distDir <- Path Abs Dir -> RIO env (Path Abs Dir)
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 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 :: String
pkgIdStr = PackageIdentifier -> String
packageIdentifierString PackageIdentifier
pkgId
        notFoundErr :: RIO env (Either Text b)
notFoundErr = Either Text b -> RIO env (Either Text b)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text b -> RIO env (Either Text b))
-> Either Text b -> RIO env (Either Text b)
forall a b. (a -> b) -> a -> b
$ Text -> Either Text b
forall a b. a -> Either a b
Left (Text -> Either Text b) -> Text -> Either Text b
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 :: Path b t -> RIO env (Either Text Text)
extractField Path b t
path = do
            Text
contents <- String -> RIO env Text
forall (m :: * -> *). MonadIO m => String -> m Text
readFileUtf8 (Path b t -> String
forall b t. Path b t -> String
toFilePath Path b t
path)
            case [Maybe Text] -> Maybe Text
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum ((Text -> Maybe Text) -> [Text] -> [Maybe Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text -> Maybe Text
T.stripPrefix (Text
field Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": ")) (Text -> [Text]
T.lines Text
contents)) 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)
forall {b}. RIO env (Either Text b)
notFoundErr
    Version
cabalVer <- Getting Version env Version -> RIO env Version
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Version env Version
forall env. HasCompiler env => SimpleGetter env Version
SimpleGetter env Version
cabalVersionL
    if Version
cabalVer Version -> Version -> Bool
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 Rel File -> Path Abs File)
-> RIO env (Path Rel File) -> RIO env (Path Abs File)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Path Abs Dir
inplaceDir Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</>) (RIO env (Path Rel File) -> RIO env (Path Abs File))
-> RIO env (Path Rel File) -> RIO env (Path Abs File)
forall a b. (a -> b) -> a -> b
$ String -> RIO env (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile (String
pkgIdStr String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-inplace.conf")
            Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Parsing config in Cabal < 1.24 location: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
path)
            Bool
exists <- Path Abs File -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
path
            if Bool
exists then (Text -> [Text]) -> Either Text Text -> Either Text [Text]
forall a b. (a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[]) (Either Text Text -> Either Text [Text])
-> RIO env (Either Text Text) -> RIO env (Either Text [Text])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path Abs File -> RIO env (Either Text Text)
forall {b} {t}. Path b t -> RIO env (Either Text Text)
extractField Path Abs File
path else RIO env (Either Text [Text])
forall {b}. RIO env (Either Text b)
notFoundErr
        else do
            -- With Cabal-1.24, it's in a different location.

            Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Scanning " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath Path Abs Dir
inplaceDir) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" for files matching " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString String
pkgIdStr
            ([Path Abs Dir]
_, [Path Abs File]
files) <- (IOException -> RIO env ([Path Abs Dir], [Path Abs File]))
-> RIO env ([Path Abs Dir], [Path Abs File])
-> RIO env ([Path Abs Dir], [Path Abs File])
forall (m :: * -> *) a.
MonadUnliftIO m =>
(IOException -> m a) -> m a -> m a
handleIO (RIO env ([Path Abs Dir], [Path Abs File])
-> IOException -> RIO env ([Path Abs Dir], [Path Abs File])
forall a b. a -> b -> a
const (RIO env ([Path Abs Dir], [Path Abs File])
 -> IOException -> RIO env ([Path Abs Dir], [Path Abs File]))
-> RIO env ([Path Abs Dir], [Path Abs File])
-> IOException
-> RIO env ([Path Abs Dir], [Path Abs File])
forall a b. (a -> b) -> a -> b
$ ([Path Abs Dir], [Path Abs File])
-> RIO env ([Path Abs Dir], [Path Abs File])
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [])) (RIO env ([Path Abs Dir], [Path Abs File])
 -> RIO env ([Path Abs Dir], [Path Abs File]))
-> RIO env ([Path Abs Dir], [Path Abs File])
-> RIO env ([Path Abs Dir], [Path Abs File])
forall a b. (a -> b) -> a -> b
$ 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
inplaceDir
            Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [Path Abs File] -> Utf8Builder
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 (String -> Text) -> (Path b File -> String) -> Path b File -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Rel File -> String
forall b t. Path b t -> String
toFilePath (Path Rel File -> String)
-> (Path b File -> Path Rel File) -> Path b File -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path b File -> Path Rel File
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" (Text -> Maybe Text) -> (Text -> Maybe Text) -> Text -> Maybe Text
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 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-"))
                stripped :: [(Text, Path Abs File)]
stripped = (Path Abs File -> Maybe (Text, Path Abs File))
-> [Path Abs File] -> [(Text, Path Abs File)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\Path Abs File
file -> (Text -> (Text, Path Abs File))
-> Maybe Text -> Maybe (Text, Path Abs File)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,Path Abs File
file) (Maybe Text -> Maybe (Text, Path Abs File))
-> (Path Abs File -> Maybe Text)
-> Path Abs File
-> Maybe (Text, Path Abs File)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Text
stripKnown (Text -> Maybe Text)
-> (Path Abs File -> Text) -> Path Abs File -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> Text
forall {b}. Path b File -> Text
toFilename (Path Abs File -> Maybe (Text, Path Abs File))
-> Path Abs File -> Maybe (Text, Path Abs File)
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 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'-') Text
n in if Text -> Bool
T.null Text
z then Text
"" else HasCallStack => Text -> Text
Text -> Text
T.tail Text
z
                matchedComponents :: [(Text, [Path Abs File])]
matchedComponents = ((Text, Path Abs File) -> (Text, [Path Abs File]))
-> [(Text, Path Abs File)] -> [(Text, [Path Abs File])]
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 = Map Text [Path Abs File] -> Set Text -> Map Text [Path Abs File]
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys (([Path Abs File] -> [Path Abs File] -> [Path Abs File])
-> [(Text, [Path Abs File])] -> Map Text [Path Abs File]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [Path Abs File] -> [Path Abs File] -> [Path Abs File]
forall a. [a] -> [a] -> [a]
(++) [(Text, [Path Abs File])]
matchedComponents) (Set Text -> Map Text [Path Abs File])
-> Set Text -> Map Text [Path Abs File]
forall a b. (a -> b) -> a -> b
$ Text -> Set Text -> Set Text
forall a. Ord a => a -> Set a -> Set a
Set.insert Text
"" Set Text
internalLibs
            Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Map Text [Path Abs File] -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow Map Text [Path Abs File]
byComponents
            if Map Text [Path Abs File] -> Bool
forall k a. Map k a -> Bool
Map.null (Map Text [Path Abs File] -> Bool)
-> Map Text [Path Abs File] -> Bool
forall a b. (a -> b) -> a -> b
$ ([Path Abs File] -> Bool)
-> Map Text [Path Abs File] -> Map Text [Path Abs File]
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (\[Path Abs File]
fs -> [Path Abs File] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Path Abs File]
fs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) Map Text [Path Abs File]
byComponents
            then case [[Path Abs File]] -> [Path Abs File]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Path Abs File]] -> [Path Abs File])
-> [[Path Abs File]] -> [Path Abs File]
forall a b. (a -> b) -> a -> b
$ Map Text [Path Abs File] -> [[Path Abs File]]
forall k a. Map k a -> [a]
Map.elems Map Text [Path Abs File]
byComponents of
                [] -> RIO env (Either Text [Text])
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) <-  [Either Text Text] -> ([Text], [Text])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either Text Text] -> ([Text], [Text]))
-> RIO env [Either Text Text] -> RIO env ([Text], [Text])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Path Abs File -> RIO env (Either Text Text))
-> [Path Abs File] -> RIO env [Either Text Text]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Path Abs File -> RIO env (Either Text Text)
forall {b} {t}. Path b t -> RIO env (Either Text Text)
extractField [Path Abs File]
paths
                  case [Text]
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
            else 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
"Multiple files matching " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (String
pkgIdStr String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-*.conf") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" found in " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                    String -> Text
T.pack (Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath Path Abs Dir
inplaceDir) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". Maybe try 'stack clean' on this package?"

displayReportPath :: (HasTerm env)
                  => StyleDoc -> Text -> StyleDoc -> RIO env ()
displayReportPath :: forall env.
HasTerm env =>
StyleDoc -> Text -> StyleDoc -> RIO env ()
displayReportPath StyleDoc
prefix Text
report StyleDoc
reportPath =
     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
prefix StyleDoc -> StyleDoc -> StyleDoc
<+> String -> StyleDoc
forall a. IsString a => String -> a
fromString (Text -> String
T.unpack Text
report) StyleDoc -> StyleDoc -> StyleDoc
<+>
                  StyleDoc
"is available at" StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc
reportPath

findExtraTixFiles :: HasEnvConfig env => RIO env [Path Abs File]
findExtraTixFiles :: forall env. HasEnvConfig env => RIO env [Path Abs File]
findExtraTixFiles = do
    Path Abs Dir
outputDir <- RIO env (Path Abs Dir)
forall env. HasEnvConfig env => RIO env (Path Abs Dir)
hpcReportDir
    let dir :: Path Abs Dir
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
    Bool
dirExists <- Path Abs Dir -> RIO env Bool
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) <- 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
            [Path Abs File] -> RIO env [Path Abs File]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Path Abs File] -> RIO env [Path Abs File])
-> [Path Abs File] -> RIO env [Path Abs File]
forall a b. (a -> b) -> a -> b
$ (Path Abs File -> Bool) -> [Path Abs File] -> [Path Abs File]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String
".tix" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`L.isSuffixOf`) (String -> Bool)
-> (Path Abs File -> String) -> Path Abs File -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> String
forall b t. Path b t -> String
toFilePath) [Path Abs File]
files
        else [Path Abs File] -> RIO env [Path Abs File]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []