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

-- | Generate HPC (Haskell Program Coverage) reports
module Stack.Coverage
    ( deleteHpcReports
    , updateTixFile
    , generateHpcReport
    , HpcReportOpts(..)
    , generateHpcReportForTargets
    , generateHpcUnifiedReport
    , generateHpcMarkupIndex
    ) where

import           Stack.Prelude hiding (Display (..))
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as BL
import           Data.List
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           Stack.Build.Target
import           Stack.Constants
import           Stack.Constants.Config
import           Stack.Package
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 qualified RIO
import           RIO.PrettyPrint
import           RIO.Process
import           Trace.Hpc.Tix
import           Web.Browser (openBrowser)

newtype CoverageException = NonTestSuiteTarget PackageName deriving Typeable

instance Exception CoverageException
instance Show CoverageException where
    show :: CoverageException -> String
show (NonTestSuiteTarget PackageName
name) = 
        String
"Can't specify anything except test-suites as hpc report targets (" String -> ShowS
forall a. [a] -> [a] -> [a]
++
        PackageName -> String
packageNameString PackageName
name String -> ShowS
forall a. [a] -> [a] -> [a]
++
        String
" is used with a non test-suite target)"

-- | Invoked at the beginning of running with "--coverage"
deleteHpcReports :: HasEnvConfig env => RIO env ()
deleteHpcReports :: 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 (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 :: 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 (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
"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 (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 (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 :: 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 (m :: * -> *) a. Monad m => a -> m a
return (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 :: 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 (m :: * -> *) a. Monad m => a -> m a
return (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 :: 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
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 (m :: * -> *) a. Monad m => a -> m a
return (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 (m :: * -> *) a. Monad m => a -> m a
return (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
RIO.display Text
err
                    Either Text (Maybe [String])
-> RIO env (Either Text (Maybe [String]))
forall (m :: * -> *) a. Monad m => a -> m a
return (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 (m :: * -> *) a. Monad m => a -> m a
return (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
RIO.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
                        Just [String]
includeNames -> String
"--include" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String] -> [String]
forall a. a -> [a] -> [a]
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 [String]
Nothing -> []
                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 (Text -> StyleDoc -> RIO env ()
forall env. HasTerm env => Text -> StyleDoc -> RIO env ()
displayReportPath 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 :: 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
"Didn't find .tix for " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                 Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
RIO.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 (m :: * -> *) a. Monad m => a -> m a
return 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
RIO.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 a. Show a => a -> String
show ProcessException
err
                 Maybe (Path Abs File) -> RIO env (Maybe (Path Abs File))
forall (m :: * -> *) a. Monad m => a -> m a
return 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 occurred while producing " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
RIO.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
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
RIO.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: The " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
                            Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
RIO.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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return (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
showList :: [HpcReportOpts] -> ShowS
$cshowList :: [HpcReportOpts] -> ShowS
show :: HpcReportOpts -> String
$cshow :: HpcReportOpts -> String
showsPrec :: Int -> HpcReportOpts -> ShowS
$cshowsPrec :: Int -> HpcReportOpts -> ShowS
Show)

generateHpcReportForTargets :: HasEnvConfig env
                            => HpcReportOpts -> [Text] -> [Text] -> RIO env ()
generateHpcReportForTargets :: 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 (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
targetNames
         then [Path Abs File] -> RIO env [Path Abs File]
forall (m :: * -> *) a. Monad m => a -> m a
return []
         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 (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
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 -> String -> RIO env [Path Abs File]
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString (String -> RIO env [Path Abs File])
-> String -> RIO env [Path Abs File]
forall a b. (a -> b) -> a -> b
$
                         String
"Error: Expected a local package, but " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                         PackageName -> String
packageNameString PackageName
name String -> ShowS
forall a. [a] -> [a] -> [a]
++
                         String
" is either an extra-dep or in the snapshot."
                     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 (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 (m :: * -> *) a. Monad m => a -> m a
return ((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
`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 (m :: * -> *) a. Monad m => a -> m a
return []
    [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)
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 (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
$
        String -> RIO env ()
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString String
"Not generating combined report, because no targets or tix files are specified."
    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 (m :: * -> *) a. Monad m => a -> m a
return (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 (m :: * -> *) a. Monad m => a -> m a
return 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 (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 Text -> StyleDoc -> RIO env ()
forall env. HasTerm env => Text -> StyleDoc -> RIO env ()
displayReportPath Text
report (Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
reportPath)

generateHpcUnifiedReport :: HasEnvConfig env => RIO env ()
generateHpcUnifiedReport :: 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 (m :: * -> *) a. Monad m => a -> m a
return ((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
`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
    if [Path Abs File] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Path Abs File]
tixFiles Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2
        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
$
            (if [Path Abs File] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Path Abs File]
tixFiles then Utf8Builder
"No tix files" else Utf8Builder
"Only one tix file") Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
            Utf8Builder
" 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 (Text -> StyleDoc -> RIO env ()
forall env. HasTerm env => Text -> StyleDoc -> RIO env ()
displayReportPath 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 :: 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 (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 (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
RIO.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]
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 (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 :: Path b File -> RIO env (Maybe Tix)
readTixOrLog Path b File
path = do
    Maybe Tix
mtix <- IO (Maybe Tix) -> RIO env (Maybe Tix)
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 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 a. Show a => a -> String
show SomeException
errorCall)
        Maybe Tix -> RIO env (Maybe Tix)
forall (m :: * -> *) a. Monad m => a -> m a
return 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
"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 (m :: * -> *) a. Monad m => a -> m a
return 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 (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 :: 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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return (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 (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 (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 (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
$
        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
"\nAn index of the generated HTML coverage reports is available 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
outputFile)

generateHpcErrorReport :: MonadIO m => Path Abs Dir -> Utf8Builder -> m ()
generateHpcErrorReport :: 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 :: 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 :: Path r Dir -> String
dirnameString = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
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 :: 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 (m :: * -> *) a. Monad m => a -> m a
return (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 (m :: * -> *) a. Monad m => a -> m a
return (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
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 (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 (m :: * -> *) a. Monad m => a -> m a
return ([], [])) (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 (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 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 (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)
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 (m :: * -> *) a. Monad m => a -> m a
return (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 (m :: * -> *) a. Monad m => a -> m a
return (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 (m :: * -> *) a. Monad m => a -> m a
return (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)
                  => Text -> StyleDoc -> RIO env ()
displayReportPath :: Text -> StyleDoc -> RIO env ()
displayReportPath 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
"The" 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 :: 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 (m :: * -> *) a. Monad m => a -> m a
return ([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
`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 (m :: * -> *) a. Monad m => a -> m a
return []