{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
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 (" forall a. [a] -> [a] -> [a]
++
PackageName -> String
packageNameString PackageName
name forall a. [a] -> [a] -> [a]
++
String
" is used with a non test-suite target)"
deleteHpcReports :: HasEnvConfig env => RIO env ()
deleteHpcReports :: forall env. HasEnvConfig env => RIO env ()
deleteHpcReports = do
Path Abs Dir
hpcDir <- forall env. HasEnvConfig env => RIO env (Path Abs Dir)
hpcReportDir
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (MonadIO m, MonadCatch m) => m a -> m ()
ignoringAbsence (forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
removeDirRecur Path Abs Dir
hpcDir)
updateTixFile :: HasEnvConfig env => PackageName -> Path Abs File -> String -> RIO env ()
updateTixFile :: forall env.
HasEnvConfig env =>
PackageName -> Path Abs File -> String -> RIO env ()
updateTixFile PackageName
pkgName' Path Abs File
tixSrc String
testName = do
Bool
exists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
tixSrc
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists forall a b. (a -> b) -> a -> b
$ do
Path Abs File
tixDest <- forall env.
HasEnvConfig env =>
PackageName -> String -> RIO env (Path Abs File)
tixFilePath PackageName
pkgName' String
testName
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (MonadIO m, MonadCatch m) => m a -> m ()
ignoringAbsence (forall (m :: * -> *) b. MonadIO m => Path b File -> m ()
removeFile Path Abs File
tixDest)
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (forall b t. Path b t -> Path b Dir
parent Path Abs File
tixDest)
Maybe Tix
mtix <- 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 -> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Failed to read " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (forall b t. Path b t -> String
toFilePath Path Abs File
tixSrc)
Just Tix
tix -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> Tix -> IO ()
writeTix (forall b t. Path b t -> String
toFilePath Path Abs File
tixDest) (Tix -> Tix
removeExeModules Tix
tix)
forall (m :: * -> *) b0 b1.
MonadIO m =>
Path b0 File -> Path b1 File -> m ()
copyFile Path Abs File
tixSrc forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). MonadThrow m => String -> m (Path Abs File)
parseAbsFile (forall b t. Path b t -> String
toFilePath Path Abs File
tixDest forall a. [a] -> [a] -> [a]
++ String
".premunging")
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (MonadIO m, MonadCatch m) => m a -> m ()
ignoringAbsence (forall (m :: * -> *) b. MonadIO m => Path b File -> m ()
removeFile Path Abs File
tixSrc)
hpcPkgPath :: HasEnvConfig env => PackageName -> RIO env (Path Abs Dir)
hpcPkgPath :: forall env.
HasEnvConfig env =>
PackageName -> RIO env (Path Abs Dir)
hpcPkgPath PackageName
pkgName' = do
Path Abs Dir
outputDir <- forall env. HasEnvConfig env => RIO env (Path Abs Dir)
hpcReportDir
Path Rel Dir
pkgNameRel <- forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir (PackageName -> String
packageNameString PackageName
pkgName')
forall (m :: * -> *) a. Monad m => a -> m a
return (Path Abs Dir
outputDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
pkgNameRel)
tixFilePath :: HasEnvConfig env
=> PackageName -> String -> RIO env (Path Abs File)
tixFilePath :: forall env.
HasEnvConfig env =>
PackageName -> String -> RIO env (Path Abs File)
tixFilePath PackageName
pkgName' String
testName = do
Path Abs Dir
pkgPath <- forall env.
HasEnvConfig env =>
PackageName -> RIO env (Path Abs Dir)
hpcPkgPath PackageName
pkgName'
Path Rel File
tixRel <- forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile (String
testName forall a. [a] -> [a] -> [a]
++ String
"/" forall a. [a] -> [a] -> [a]
++ String
testName forall a. [a] -> [a] -> [a]
++ String
".tix")
forall (m :: * -> *) a. Monad m => a -> m a
return (Path Abs Dir
pkgPath forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
tixRel)
generateHpcReport :: HasEnvConfig env
=> Path Abs Dir -> Package -> [Text] -> RIO env ()
generateHpcReport :: forall env.
HasEnvConfig env =>
Path Abs Dir -> Package -> [Text] -> RIO env ()
generateHpcReport Path Abs Dir
pkgDir Package
package [Text]
tests = do
ActualCompiler
compilerVersion <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasSourceMap env => SimpleGetter env ActualCompiler
actualCompilerVersionL
let pkgName' :: Text
pkgName' = String -> Text
T.pack 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 <-
if Version
ghcVersion forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
7, Int
10] then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just [String
pkgId]
else if Bool -> Bool
not Bool
hasLibrary Bool -> Bool -> Bool
&& forall a. Set a -> Bool
Set.null Set Text
internalLibs then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a. Maybe a
Nothing
else do
let hpcNameField :: Text
hpcNameField = if Version
ghcVersion forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
8, Int
0] then Text
"id" else Text
"key"
Either Text [Text]
eincludeName <- forall env.
HasEnvConfig env =>
Path Abs Dir
-> PackageIdentifier
-> Set Text
-> Text
-> RIO env (Either Text [Text])
findPackageFieldForBuiltPackage Path Abs Dir
pkgDir (Package -> PackageIdentifier
packageIdentifier Package
package) Set Text
internalLibs Text
hpcNameField
case Either Text [Text]
eincludeName of
Left Text
err -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Utf8Builder
RIO.display Text
err
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Text
err
Right [Text]
includeNames -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack [Text]
includeNames
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Text]
tests forall a b. (a -> b) -> a -> b
$ \Text
testName -> do
Path Abs File
tixSrc <- forall env.
HasEnvConfig env =>
PackageName -> String -> RIO env (Path Abs File)
tixFilePath (Package -> PackageName
packageName Package
package) (Text -> String
T.unpack Text
testName)
let report :: Text
report = Text
"coverage report for " forall a. Semigroup a => a -> a -> a
<> Text
pkgName' forall a. Semigroup a => a -> a -> a
<> Text
"'s test-suite \"" forall a. Semigroup a => a -> a -> a
<> Text
testName forall a. Semigroup a => a -> a -> a
<> Text
"\""
reportDir :: Path Abs Dir
reportDir = forall b t. Path b t -> Path b Dir
parent Path Abs File
tixSrc
case Either Text (Maybe [String])
eincludeName of
Left Text
err -> forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> Utf8Builder -> m ()
generateHpcErrorReport Path Abs Dir
reportDir (forall a. Display a => a -> Utf8Builder
RIO.display (String -> Text
sanitize (Text -> String
T.unpack Text
err)))
Right Maybe [String]
mincludeName -> do
let extraArgs :: [String]
extraArgs = case Maybe [String]
mincludeName of
Just [String]
includeNames -> String
"--include" forall a. a -> [a] -> [a]
: forall a. a -> [a] -> [a]
intersperse String
"--include" (forall a b. (a -> b) -> [a] -> [b]
map (\String
n -> String
n forall a. [a] -> [a] -> [a]
++ String
":") [String]
includeNames)
Maybe [String]
Nothing -> []
Maybe (Path Abs File)
mreportPath <- 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
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (Path Abs File)
mreportPath (forall env.
HasTerm env =>
StyleDoc -> Text -> StyleDoc -> RIO env ()
displayReportPath StyleDoc
"The" Text
report forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> StyleDoc
pretty)
generateHpcReportInternal :: HasEnvConfig env
=> Path Abs File -> Path Abs Dir -> Text -> [String] -> [String]
-> RIO env (Maybe (Path Abs File))
generateHpcReportInternal :: forall env.
HasEnvConfig env =>
Path Abs File
-> Path Abs Dir
-> Text
-> [String]
-> [String]
-> RIO env (Maybe (Path Abs File))
generateHpcReportInternal Path Abs File
tixSrc Path Abs Dir
reportDir Text
report [String]
extraMarkupArgs [String]
extraReportArgs = do
Bool
tixFileExists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
tixSrc
if Bool -> Bool
not Bool
tixFileExists
then do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError forall a b. (a -> b) -> a -> b
$
Utf8Builder
"Didn't find .tix for " forall a. Semigroup a => a -> a -> a
<>
forall a. Display a => a -> Utf8Builder
RIO.display Text
report forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
" - expected to find it at " forall a. Semigroup a => a -> a -> a
<>
forall a. IsString a => String -> a
fromString (forall b t. Path b t -> String
toFilePath Path Abs File
tixSrc) forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
"."
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
else (forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(ProcessException
err :: ProcessException) -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> Utf8Builder
displayShow ProcessException
err
forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> Utf8Builder -> m ()
generateHpcErrorReport Path Abs Dir
reportDir forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Utf8Builder
RIO.display forall a b. (a -> b) -> a -> b
$ String -> Text
sanitize forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show ProcessException
err
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$
(forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`onException` forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Utf8Builder
"Error occurred while producing " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
RIO.display Text
report)) forall a b. (a -> b) -> a -> b
$ do
Path Rel Dir
hpcRelDir <- forall (m :: * -> *) env.
(MonadThrow m, MonadReader env m, HasEnvConfig env) =>
m (Path Rel Dir)
hpcRelativeDir
[Path Abs Dir]
pkgDirs <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasBuildConfig env => Lens' env BuildConfig
buildConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to (forall a b. (a -> b) -> [a] -> [b]
map ProjectPackage -> Path Abs Dir
ppRoot forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
Map.elems forall b c a. (b -> c) -> (a -> b) -> a -> c
. SMWanted -> Map PackageName ProjectPackage
smwProject forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildConfig -> SMWanted
bcSMWanted)
let args :: [String]
args =
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Path Abs Dir
x -> [String
"--srcdir", forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
x]) [Path Abs Dir]
pkgDirs forall a. [a] -> [a] -> [a]
++
[String
"--hpcdir", forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Rel Dir
hpcRelDir, String
"--reset-hpcdirs"]
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Generating " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
RIO.display Text
report
[ByteString]
outputLines <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Bool) -> ByteString -> ByteString
S8.filter (forall a. Eq a => a -> a -> Bool
/= Char
'\r')) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
S8.lines forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
MonadIO m, HasCallStack) =>
String -> [String] -> (ProcessConfig () () () -> m a) -> m a
proc String
"hpc"
( String
"report"
forall a. a -> [a] -> [a]
: forall b t. Path b t -> String
toFilePath Path Abs File
tixSrc
forall a. a -> [a] -> [a]
: ([String]
args forall a. [a] -> [a] -> [a]
++ [String]
extraReportArgs)
)
forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ByteString, ByteString)
readProcess_
if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (ByteString
"(0/0)" ByteString -> ByteString -> Bool
`S8.isSuffixOf`) [ByteString]
outputLines
then do
let msg :: Bool -> Utf8Builder
msg Bool
html =
Utf8Builder
"Error: The " forall a. Semigroup a => a -> a -> a
<>
forall a. Display a => a -> Utf8Builder
RIO.display Text
report forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
" did not consider any code. One possible cause of this is" forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
" if your test-suite builds the library code (see stack " forall a. Semigroup a => a -> a -> a
<>
(if Bool
html then Utf8Builder
"<a href='https://github.com/commercialhaskell/stack/issues/1008'>" else Utf8Builder
"") forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
"issue #1008" forall a. Semigroup a => a -> a -> a
<>
(if Bool
html then Utf8Builder
"</a>" else Utf8Builder
"") forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
"). It may also indicate a bug in stack or" forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
" the hpc program. Please report this issue if you think" forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
" your coverage report should have meaningful results."
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError (Bool -> Utf8Builder
msg Bool
False)
forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> Utf8Builder -> m ()
generateHpcErrorReport Path Abs Dir
reportDir (Bool -> Utf8Builder
msg Bool
True)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
else do
let reportPath :: Path Abs File
reportPath = Path Abs Dir
reportDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileHpcIndexHtml
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ByteString]
outputLines (forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Utf8Builder
displayBytesUtf8)
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
MonadIO m, HasCallStack) =>
String -> [String] -> (ProcessConfig () () () -> m a) -> m a
proc String
"hpc"
( String
"markup"
forall a. a -> [a] -> [a]
: forall b t. Path b t -> String
toFilePath Path Abs File
tixSrc
forall a. a -> [a] -> [a]
: (String
"--destdir=" forall a. [a] -> [a] -> [a]
++ forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
reportDir)
forall a. a -> [a] -> [a]
: ([String]
args forall a. [a] -> [a] -> [a]
++ [String]
extraMarkupArgs)
)
forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ByteString, ByteString)
readProcess_
forall (m :: * -> *) a. Monad m => a -> m a
return (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
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 :: forall env.
HasEnvConfig env =>
HpcReportOpts -> [Text] -> [Text] -> RIO env ()
generateHpcReportForTargets HpcReportOpts
opts [Text]
tixFiles [Text]
targetNames = do
[Path Abs File]
targetTixFiles <-
if Bool -> Bool
not (HpcReportOpts -> Bool
hroptsAll HpcReportOpts
opts) Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
targetNames
then forall (m :: * -> *) a. Monad m => a -> m a
return []
else do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HpcReportOpts -> Bool
hroptsAll HpcReportOpts
opts Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
targetNames)) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Since --all is used, it is redundant to specify these targets: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow [Text]
targetNames
Map PackageName Target
targets <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to EnvConfig -> SourceMap
envConfigSourceMapforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to SourceMap -> SMTargets
smTargetsforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to SMTargets -> Map PackageName Target
smtTargets
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName Target
targets) forall a b. (a -> b) -> a -> b
$ \(PackageName
name, Target
target) ->
case Target
target of
TargetAll PackageType
PTDependency -> forall (m :: * -> *) a. (MonadIO m, HasCallStack) => String -> m a
throwString forall a b. (a -> b) -> a -> b
$
String
"Error: Expected a local package, but " forall a. [a] -> [a] -> [a]
++
PackageName -> String
packageNameString PackageName
name forall a. [a] -> [a] -> [a]
++
String
" is either an extra-dep or in the snapshot."
TargetComps Set NamedComponent
comps -> do
Path Abs Dir
pkgPath <- forall env.
HasEnvConfig env =>
PackageName -> RIO env (Path Abs Dir)
hpcPkgPath PackageName
name
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set NamedComponent
comps) forall a b. (a -> b) -> a -> b
$ \NamedComponent
nc ->
case NamedComponent
nc of
CTest Text
testName ->
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Path Abs Dir
pkgPath forall b t. Path b Dir -> Path Rel t -> Path b t
</>) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile (Text -> String
T.unpack Text
testName forall a. [a] -> [a] -> [a]
++ String
"/" forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
testName forall a. [a] -> [a] -> [a]
++ String
".tix")
NamedComponent
_ -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ PackageName -> CoverageException
NonTestSuiteTarget PackageName
name
TargetAll PackageType
PTProject -> do
Path Abs Dir
pkgPath <- forall env.
HasEnvConfig env =>
PackageName -> RIO env (Path Abs Dir)
hpcPkgPath PackageName
name
Bool
exists <- forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist Path Abs Dir
pkgPath
if Bool
exists
then do
([Path Abs Dir]
dirs, [Path Abs File]
_) <- forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
pkgPath
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Path Abs Dir]
dirs forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
dir -> do
([Path Abs Dir]
_, [Path Abs File]
files) <- forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
dir
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. (a -> Bool) -> [a] -> [a]
filter ((String
".tix" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> String
toFilePath) [Path Abs File]
files)
else forall (m :: * -> *) a. Monad m => a -> m a
return []
[Path Abs File]
tixPaths <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\[Path Abs File]
xs -> [Path Abs File]
xs forall a. [a] -> [a] -> [a]
++ [Path Abs File]
targetTixFiles) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *). MonadIO m => String -> m (Path Abs File)
resolveFile' forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) [Text]
tixFiles
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Path Abs File]
tixPaths) forall a b. (a -> b) -> a -> b
$
forall (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 <- forall env. HasEnvConfig env => RIO env (Path Abs Dir)
hpcReportDir
Path Abs Dir
reportDir <- case HpcReportOpts -> Maybe String
hroptsDestDir HpcReportOpts
opts of
Maybe String
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (Path Abs Dir
outputDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirCombined forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirCustom)
Just String
destDir -> do
Path Abs Dir
dest <- forall (m :: * -> *). MonadIO m => String -> m (Path Abs Dir)
resolveDir' String
destDir
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
dest
forall (m :: * -> *) a. Monad m => a -> m a
return Path Abs Dir
dest
let report :: Text
report = Text
"combined report"
Maybe (Path Abs File)
mreportPath <- 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
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (Path Abs File)
mreportPath forall a b. (a -> b) -> a -> b
$ \Path Abs File
reportPath ->
if HpcReportOpts -> Bool
hroptsOpenBrowser HpcReportOpts
opts
then do
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo forall a b. (a -> b) -> a -> b
$ StyleDoc
"Opening" StyleDoc -> StyleDoc -> StyleDoc
<+> forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
reportPath StyleDoc -> StyleDoc -> StyleDoc
<+> StyleDoc
"in the browser."
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Bool
openBrowser (forall b t. Path b t -> String
toFilePath Path Abs File
reportPath)
else forall env.
HasTerm env =>
StyleDoc -> Text -> StyleDoc -> RIO env ()
displayReportPath StyleDoc
"The" Text
report (forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
reportPath)
generateHpcUnifiedReport :: HasEnvConfig env => RIO env ()
generateHpcUnifiedReport :: forall env. HasEnvConfig env => RIO env ()
generateHpcUnifiedReport = do
Path Abs Dir
outputDir <- forall env. HasEnvConfig env => RIO env (Path Abs Dir)
hpcReportDir
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
outputDir
([Path Abs Dir]
dirs, [Path Abs File]
_) <- forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
outputDir
[Path Abs File]
tixFiles0 <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall a. (a -> Bool) -> [a] -> [a]
filter ((String
"combined" forall a. Eq a => a -> a -> Bool
/=) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall loc. Path loc Dir -> String
dirnameString) [Path Abs Dir]
dirs) forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
dir -> do
([Path Abs Dir]
dirs', [Path Abs File]
_) <- forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
dir
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Path Abs Dir]
dirs' forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
dir' -> do
([Path Abs Dir]
_, [Path Abs File]
files) <- forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
dir'
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. (a -> Bool) -> [a] -> [a]
filter ((String
".tix" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> String
toFilePath) [Path Abs File]
files)
[Path Abs File]
extraTixFiles <- forall env. HasEnvConfig env => RIO env [Path Abs File]
findExtraTixFiles
let tixFiles :: [Path Abs File]
tixFiles = [Path Abs File]
tixFiles0 forall a. [a] -> [a] -> [a]
++ [Path Abs File]
extraTixFiles
reportDir :: Path Abs Dir
reportDir = Path Abs Dir
outputDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirCombined forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirAll
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Path Abs File]
tixFiles
then forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo forall a b. (a -> b) -> a -> b
$ Utf8Builder
"No tix files found in " forall a. Semigroup a => a -> a -> a
<>
forall a. IsString a => String -> a
fromString (forall b t. Path b t -> String
toFilePath Path Abs Dir
outputDir) 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 <- 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
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (Path Abs File)
mreportPath (forall env.
HasTerm env =>
StyleDoc -> Text -> StyleDoc -> RIO env ()
displayReportPath StyleDoc
"The" Text
report forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> StyleDoc
pretty)
generateUnionReport :: HasEnvConfig env
=> Text -> Path Abs Dir -> [Path Abs File]
-> RIO env (Maybe (Path Abs File))
generateUnionReport :: forall env.
HasEnvConfig env =>
Text
-> Path Abs Dir
-> [Path Abs File]
-> RIO env (Maybe (Path Abs File))
generateUnionReport Text
report Path Abs Dir
reportDir [Path Abs File]
tixFiles = do
([String]
errs, Tix
tix) <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Tix] -> ([String], Tix)
unionTixes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Tix -> Tix
removeExeModules) (forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM forall env b. HasLogFunc env => Path b File -> RIO env (Maybe Tix)
readTixOrLog [Path Abs File]
tixFiles)
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Using the following tix files: " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (forall a. Show a => a -> String
show [Path Abs File]
tixFiles)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
errs) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$
Utf8Builder
"The following modules are left out of the " forall a. Semigroup a => a -> a -> a
<>
forall a. Display a => a -> Utf8Builder
RIO.display Text
report forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
" due to version mismatches: " forall a. Semigroup a => a -> a -> a
<>
forall a. Monoid a => [a] -> a
mconcat (forall a. a -> [a] -> [a]
intersperse Utf8Builder
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a. IsString a => String -> a
fromString [String]
errs))
Path Abs File
tixDest <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Path Abs Dir
reportDir forall b t. Path b Dir -> Path Rel t -> Path b t
</>) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile (forall loc. Path loc Dir -> String
dirnameString Path Abs Dir
reportDir forall a. [a] -> [a] -> [a]
++ String
".tix")
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (forall b t. Path b t -> Path b Dir
parent Path Abs File
tixDest)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> Tix -> IO ()
writeTix (forall b t. Path b t -> String
toFilePath Path Abs File
tixDest) Tix
tix
forall env.
HasEnvConfig env =>
Path Abs File
-> Path Abs Dir
-> Text
-> [String]
-> [String]
-> RIO env (Maybe (Path Abs File))
generateHpcReportInternal Path Abs File
tixDest Path Abs Dir
reportDir Text
report [] []
readTixOrLog :: HasLogFunc env => Path b File -> RIO env (Maybe Tix)
readTixOrLog :: forall env b. HasLogFunc env => Path b File -> RIO env (Maybe Tix)
readTixOrLog Path b File
path = do
Maybe Tix
mtix <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO (Maybe Tix)
readTix (forall b t. Path b t -> String
toFilePath Path b File
path)) forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
errorCall -> do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Error while reading tix: " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (forall a. Show a => a -> String
show SomeException
errorCall)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing Maybe Tix
mtix) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Failed to read tix file " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (forall b t. Path b t -> String
toFilePath Path b File
path)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Tix
mtix
removeExeModules :: Tix -> Tix
removeExeModules :: Tix -> Tix
removeExeModules (Tix [TixModule]
ms) = [TixModule] -> Tix
Tix (forall a. (a -> Bool) -> [a] -> [a]
filter (\(TixModule String
name Hash
_ Int
_ [Integer]
_) -> Char
'/' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
name) [TixModule]
ms)
unionTixes :: [Tix] -> ([String], Tix)
unionTixes :: [Tix] -> ([String], Tix)
unionTixes [Tix]
tixes = (forall k a. Map k a -> [k]
Map.keys Map String ()
errs, [TixModule] -> Tix
Tix (forall k a. Map k a -> [a]
Map.elems Map String TixModule
outputs))
where
(Map String ()
errs, Map String TixModule
outputs) = forall a b c k. (a -> Either b c) -> Map k a -> (Map k b, Map k c)
Map.mapEither forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith forall {a} {a}.
Either a TixModule -> Either a TixModule -> Either () TixModule
merge forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Tix -> Map String (Either a TixModule)
toMap [Tix]
tixes
toMap :: Tix -> Map String (Either a TixModule)
toMap (Tix [TixModule]
ms) = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall a b. (a -> b) -> [a] -> [b]
map (\x :: TixModule
x@(TixModule String
k Hash
_ Int
_ [Integer]
_) -> (String
k, forall a b. b -> Either a b
Right TixModule
x)) [TixModule]
ms)
merge :: Either a TixModule -> Either a TixModule -> Either () TixModule
merge (Right (TixModule String
k Hash
hash1 Int
len1 [Integer]
tix1))
(Right (TixModule String
_ Hash
hash2 Int
len2 [Integer]
tix2))
| Hash
hash1 forall a. Eq a => a -> a -> Bool
== Hash
hash2 Bool -> Bool -> Bool
&& Int
len1 forall a. Eq a => a -> a -> Bool
== Int
len2 = forall a b. b -> Either a b
Right (String -> Hash -> Int -> [Integer] -> TixModule
TixModule String
k Hash
hash1 Int
len1 (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. Num a => a -> a -> a
(+) [Integer]
tix1 [Integer]
tix2))
merge Either a TixModule
_ Either a TixModule
_ = forall a b. a -> Either a b
Left ()
generateHpcMarkupIndex :: HasEnvConfig env => RIO env ()
generateHpcMarkupIndex :: forall env. HasEnvConfig env => RIO env ()
generateHpcMarkupIndex = do
Path Abs Dir
outputDir <- forall env. HasEnvConfig env => RIO env (Path Abs Dir)
hpcReportDir
let outputFile :: Path Abs File
outputFile = Path Abs Dir
outputDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileIndexHtml
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
outputDir
([Path Abs Dir]
dirs, [Path Abs File]
_) <- forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
outputDir
[Text]
rows <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a. [Maybe a] -> [a]
catMaybes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Path Abs Dir]
dirs forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
dir -> do
([Path Abs Dir]
subdirs, [Path Abs File]
_) <- forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
dir
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Path Abs Dir]
subdirs forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
subdir -> do
let indexPath :: Path Abs File
indexPath = Path Abs Dir
subdir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileHpcIndexHtml
Bool
exists' <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
indexPath
if Bool -> Bool
not Bool
exists' then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing else do
Path Rel File
relPath <- forall (m :: * -> *) b t.
MonadThrow m =>
Path b Dir -> Path b t -> m (Path Rel t)
stripProperPrefix Path Abs Dir
outputDir Path Abs File
indexPath
let package :: Path Rel Dir
package = forall b. Path b Dir -> Path Rel Dir
dirname Path Abs Dir
dir
testsuite :: Path Rel Dir
testsuite = forall b. Path b Dir -> Path Rel Dir
dirname Path Abs Dir
subdir
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
[ Text
"<tr><td>"
, forall b t. Path b t -> Text
pathToHtml Path Rel Dir
package
, Text
"</td><td><a href=\""
, forall b t. Path b t -> Text
pathToHtml Path Rel File
relPath
, Text
"\">"
, forall b t. Path b t -> Text
pathToHtml Path Rel Dir
testsuite
, Text
"</a></td></tr>"
]
forall (m :: * -> *) absrel.
MonadIO m =>
Path absrel File -> Builder -> m ()
writeBinaryFileAtomic Path Abs File
outputFile forall a b. (a -> b) -> a -> b
$
Builder
"<html><head><meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\">" forall a. Semigroup a => a -> a -> a
<>
Builder
"<style type=\"text/css\">" forall a. Semigroup a => a -> a -> a
<>
Builder
"table.dashboard { border-collapse: collapse; border: solid 1px black }" forall a. Semigroup a => a -> a -> a
<>
Builder
".dashboard td { border: solid 1px black }" forall a. Semigroup a => a -> a -> a
<>
Builder
".dashboard th { border: solid 1px black }" forall a. Semigroup a => a -> a -> a
<>
Builder
"</style>" forall a. Semigroup a => a -> a -> a
<>
Builder
"</head>" forall a. Semigroup a => a -> a -> a
<>
Builder
"<body>" forall a. Semigroup a => a -> a -> a
<>
(if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
rows
then
Builder
"<b>No hpc_index.html files found in \"" forall a. Semigroup a => a -> a -> a
<>
Text -> Builder
encodeUtf8Builder (forall b t. Path b t -> Text
pathToHtml Path Abs Dir
outputDir) forall a. Semigroup a => a -> a -> a
<>
Builder
"\".</b>"
else
Builder
"<table class=\"dashboard\" width=\"100%\" border=\"1\"><tbody>" forall a. Semigroup a => a -> a -> a
<>
Builder
"<p><b>NOTE: This is merely a listing of the html files found in the coverage reports directory. Some of these reports may be old.</b></p>" forall a. Semigroup a => a -> a -> a
<>
Builder
"<tr><th>Package</th><th>TestSuite</th><th>Modification Time</th></tr>" forall a. Semigroup a => a -> a -> a
<>
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Text -> Builder
encodeUtf8Builder [Text]
rows forall a. Semigroup a => a -> a -> a
<>
Builder
"</tbody></table>") forall a. Semigroup a => a -> a -> a
<>
Builder
"</body></html>"
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
rows) forall a b. (a -> b) -> a -> b
$
forall env.
HasTerm env =>
StyleDoc -> Text -> StyleDoc -> RIO env ()
displayReportPath StyleDoc
"\nAn" Text
"index of the generated HTML coverage reports"
(forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
outputFile)
generateHpcErrorReport :: MonadIO m => Path Abs Dir -> Utf8Builder -> m ()
generateHpcErrorReport :: forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> Utf8Builder -> m ()
generateHpcErrorReport Path Abs Dir
dir Utf8Builder
err = do
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
dir
let fp :: String
fp = forall b t. Path b t -> String
toFilePath (Path Abs Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileHpcIndexHtml)
forall (m :: * -> *). MonadIO m => String -> Utf8Builder -> m ()
writeFileUtf8Builder String
fp forall a b. (a -> b) -> a -> b
$
Utf8Builder
"<html><head><meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\"></head><body>" forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
"<h1>HPC Report Generation Error</h1>" forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
"<p>" forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
err forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
"</p>" forall a. Semigroup a => a -> a -> a
<>
Utf8Builder
"</body></html>"
pathToHtml :: Path b t -> Text
pathToHtml :: forall b t. Path b t -> Text
pathToHtml = (Char -> Bool) -> Text -> Text
T.dropWhileEnd (forall a. Eq a => a -> a -> Bool
==Char
'/') forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
sanitize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> String
toFilePath
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
"&"
proc_ Char
'\\' = Text
"\"
proc_ Char
'"' = Text
"""
proc_ Char
'\'' = Text
"'"
proc_ Char
'<' = Text
"<"
proc_ Char
'>' = Text
">"
proc_ Char
h = Char -> Text
LT.singleton Char
h
sanitize :: String -> Text
sanitize :: String -> Text
sanitize = Text -> Text
LT.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
htmlEscape forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
LT.pack
dirnameString :: Path r Dir -> String
dirnameString :: forall loc. Path loc Dir -> String
dirnameString = forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Char -> Bool
isPathSeparator forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> String
toFilePath forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. Path b Dir -> Path Rel Dir
dirname
findPackageFieldForBuiltPackage
:: HasEnvConfig env
=> Path Abs Dir -> PackageIdentifier -> Set.Set Text -> Text
-> RIO env (Either Text [Text])
findPackageFieldForBuiltPackage :: forall env.
HasEnvConfig env =>
Path Abs Dir
-> PackageIdentifier
-> Set Text
-> Text
-> RIO env (Either Text [Text])
findPackageFieldForBuiltPackage Path Abs Dir
pkgDir PackageIdentifier
pkgId Set Text
internalLibs Text
field = do
Path Abs Dir
distDir <- forall (m :: * -> *) env.
(MonadThrow m, MonadReader env m, HasEnvConfig env) =>
Path Abs Dir -> m (Path Abs Dir)
distDirFromDir Path Abs Dir
pkgDir
let inplaceDir :: Path Abs Dir
inplaceDir = Path Abs Dir
distDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirPackageConfInplace
pkgIdStr :: String
pkgIdStr = PackageIdentifier -> String
packageIdentifierString PackageIdentifier
pkgId
notFoundErr :: RIO env (Either Text b)
notFoundErr = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Failed to find package key for " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
pkgIdStr
extractField :: Path b t -> RIO env (Either Text Text)
extractField Path b t
path = do
Text
contents <- forall (m :: * -> *). MonadIO m => String -> m Text
readFileUtf8 (forall b t. Path b t -> String
toFilePath Path b t
path)
case forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum (forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text -> Maybe Text
T.stripPrefix (Text
field forall a. Semigroup a => a -> a -> a
<> Text
": ")) (Text -> [Text]
T.lines Text
contents)) of
Just Text
result -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text -> Text
T.strip Text
result
Maybe Text
Nothing -> forall {b}. RIO env (Either Text b)
notFoundErr
Version
cabalVer <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasCompiler env => SimpleGetter env Version
cabalVersionL
if Version
cabalVer forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
1, Int
24]
then do
Path Abs File
path <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Path Abs Dir
inplaceDir forall b t. Path b Dir -> Path Rel t -> Path b t
</>) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile (String
pkgIdStr forall a. [a] -> [a] -> [a]
++ String
"-inplace.conf")
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Parsing config in Cabal < 1.24 location: " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (forall b t. Path b t -> String
toFilePath Path Abs File
path)
Bool
exists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
path
if Bool
exists then forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {b} {t}. Path b t -> RIO env (Either Text Text)
extractField Path Abs File
path else forall {b}. RIO env (Either Text b)
notFoundErr
else do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Scanning " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (forall b t. Path b t -> String
toFilePath Path Abs Dir
inplaceDir) forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" for files matching " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString String
pkgIdStr
([Path Abs Dir]
_, [Path Abs File]
files) <- forall (m :: * -> *) a.
MonadUnliftIO m =>
(IOException -> m a) -> m a -> m a
handleIO (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
inplaceDir
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> Utf8Builder
displayShow [Path Abs File]
files
let toFilename :: Path b File -> Text
toFilename = String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> String
toFilePath forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. Path b File -> Path Rel File
filename
stripKnown :: Text -> Maybe Text
stripKnown = Text -> Text -> Maybe Text
T.stripSuffix Text
".conf" forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Text -> Text -> Maybe Text
T.stripPrefix (String -> Text
T.pack (String
pkgIdStr forall a. [a] -> [a] -> [a]
++ String
"-"))
stripped :: [(Text, Path Abs File)]
stripped = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\Path Abs File
file -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,Path Abs File
file) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Text
stripKnown forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {b}. Path b File -> Text
toFilename forall a b. (a -> b) -> a -> b
$ Path Abs File
file) [Path Abs File]
files
stripHash :: Text -> Text
stripHash Text
n = let z :: Text
z = (Char -> Bool) -> Text -> Text
T.dropWhile (forall a. Eq a => a -> a -> Bool
/= Char
'-') Text
n in if Text -> Bool
T.null Text
z then Text
"" else Text -> Text
T.tail Text
z
matchedComponents :: [(Text, [Path Abs File])]
matchedComponents = forall a b. (a -> b) -> [a] -> [b]
map (\(Text
n, Path Abs File
f) -> (Text -> Text
stripHash Text
n, [Path Abs File
f])) [(Text, Path Abs File)]
stripped
byComponents :: Map Text [Path Abs File]
byComponents = forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys (forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. [a] -> [a] -> [a]
(++) [(Text, [Path Abs File])]
matchedComponents) forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> Set a -> Set a
Set.insert Text
"" Set Text
internalLibs
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> Utf8Builder
displayShow Map Text [Path Abs File]
byComponents
if forall k a. Map k a -> Bool
Map.null forall a b. (a -> b) -> a -> b
$ forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (\[Path Abs File]
fs -> forall (t :: * -> *) a. Foldable t => t a -> Int
length [Path Abs File]
fs forall a. Ord a => a -> a -> Bool
> Int
1) Map Text [Path Abs File]
byComponents
then case forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems Map Text [Path Abs File]
byComponents of
[] -> forall {b}. RIO env (Either Text b)
notFoundErr
[Path Abs File]
paths -> do
([Text]
errors, [Text]
keys) <- forall a b. [Either a b] -> ([a], [b])
partitionEithers forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {b} {t}. Path b t -> RIO env (Either Text Text)
extractField [Path Abs File]
paths
case [Text]
errors of
(Text
a:[Text]
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Text
a
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right [Text]
keys
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Multiple files matching " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (String
pkgIdStr forall a. [a] -> [a] -> [a]
++ String
"-*.conf") forall a. Semigroup a => a -> a -> a
<> Text
" found in " forall a. Semigroup a => a -> a -> a
<>
String -> Text
T.pack (forall b t. Path b t -> String
toFilePath Path Abs Dir
inplaceDir) forall a. Semigroup a => a -> a -> a
<> Text
". Maybe try 'stack clean' on this package?"
displayReportPath :: (HasTerm env)
=> StyleDoc -> Text -> StyleDoc -> RIO env ()
displayReportPath :: forall env.
HasTerm env =>
StyleDoc -> Text -> StyleDoc -> RIO env ()
displayReportPath StyleDoc
prefix Text
report StyleDoc
reportPath =
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo forall a b. (a -> b) -> a -> b
$ StyleDoc
prefix StyleDoc -> StyleDoc -> 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]
= do
Path Abs Dir
outputDir <- forall env. HasEnvConfig env => RIO env (Path Abs Dir)
hpcReportDir
let dir :: Path Abs Dir
dir = Path Abs Dir
outputDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirExtraTixFiles
Bool
dirExists <- forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist Path Abs Dir
dir
if Bool
dirExists
then do
([Path Abs Dir]
_, [Path Abs File]
files) <- forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
dir
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter ((String
".tix" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> String
toFilePath) [Path Abs File]
files
else forall (m :: * -> *) a. Monad m => a -> m a
return []