{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleInstances #-}
{-# 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 (" 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)"
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)
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)
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)
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)
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)
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)
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
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 <-
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]
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
else do
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)))
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
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
Path Rel Dir
hpcRelDir <- RIO env (Path Rel Dir)
forall (m :: * -> *) env.
(MonadThrow m, MonadReader env m, HasEnvConfig env) =>
m (Path Rel Dir)
hpcRelativeDir
[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 =
(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]
++
[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
[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)
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 <-
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
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
<>
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
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 (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
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
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
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
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
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
[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
[] -> 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]
= 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 []