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

-- | Generate HPC (Haskell Program Coverage) reports

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

import           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)"

-- | Invoked at the beginning of running with "--coverage"

deleteHpcReports :: HasEnvConfig env => RIO env ()
deleteHpcReports :: forall env. HasEnvConfig env => RIO env ()
deleteHpcReports = do
    Path Abs Dir
hpcDir <- forall env. HasEnvConfig env => RIO env (Path Abs Dir)
hpcReportDir
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (MonadIO m, MonadCatch m) => m a -> m ()
ignoringAbsence (forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
removeDirRecur Path Abs Dir
hpcDir)

-- | Move a tix file into a sub-directory of the hpc report directory. Deletes the old one if one is

-- present.

updateTixFile :: HasEnvConfig env => PackageName -> Path Abs File -> String -> RIO env ()
updateTixFile :: forall env.
HasEnvConfig env =>
PackageName -> Path Abs File -> String -> RIO env ()
updateTixFile PackageName
pkgName' Path Abs File
tixSrc String
testName = do
    Bool
exists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
tixSrc
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists forall a b. (a -> b) -> a -> b
$ do
        Path Abs File
tixDest <- forall env.
HasEnvConfig env =>
PackageName -> String -> RIO env (Path Abs File)
tixFilePath PackageName
pkgName' String
testName
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (MonadIO m, MonadCatch m) => m a -> m ()
ignoringAbsence (forall (m :: * -> *) b. MonadIO m => Path b File -> m ()
removeFile Path Abs File
tixDest)
        forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir (forall b t. Path b t -> Path b Dir
parent Path Abs File
tixDest)
        -- Remove exe modules because they are problematic. This could be revisited if there's a GHC

        -- version that fixes https://ghc.haskell.org/trac/ghc/ticket/1853

        Maybe Tix
mtix <- forall env b. 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)
                -- TODO: ideally we'd do a file move, but IIRC this can

                -- have problems. Something about moving between drives

                -- on windows?

                forall (m :: * -> *) b0 b1.
MonadIO m =>
Path b0 File -> Path b1 File -> m ()
copyFile Path Abs File
tixSrc forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). MonadThrow m => String -> m (Path Abs File)
parseAbsFile (forall b t. Path b t -> String
toFilePath Path Abs File
tixDest forall a. [a] -> [a] -> [a]
++ String
".premunging")
                forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (MonadIO m, MonadCatch m) => m a -> m ()
ignoringAbsence (forall (m :: * -> *) b. MonadIO m => Path b File -> m ()
removeFile Path Abs File
tixSrc)

-- | Get the directory used for hpc reports for the given pkgId.

hpcPkgPath :: HasEnvConfig env => PackageName -> RIO env (Path Abs Dir)
hpcPkgPath :: forall env.
HasEnvConfig env =>
PackageName -> RIO env (Path Abs Dir)
hpcPkgPath PackageName
pkgName' = do
    Path Abs Dir
outputDir <- forall env. HasEnvConfig env => RIO env (Path Abs Dir)
hpcReportDir
    Path Rel Dir
pkgNameRel <- forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir (PackageName -> String
packageNameString PackageName
pkgName')
    forall (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)

-- | Get the tix file location, given the name of the file (without extension), and the package

-- identifier string.

tixFilePath :: HasEnvConfig env
            => PackageName -> String -> RIO env (Path Abs File)
tixFilePath :: forall env.
HasEnvConfig env =>
PackageName -> String -> RIO env (Path Abs File)
tixFilePath PackageName
pkgName' String
testName = do
    Path Abs Dir
pkgPath <- forall env.
HasEnvConfig env =>
PackageName -> RIO env (Path Abs Dir)
hpcPkgPath PackageName
pkgName'
    Path Rel File
tixRel <- forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile (String
testName forall a. [a] -> [a] -> [a]
++ String
"/" forall a. [a] -> [a] -> [a]
++ String
testName forall a. [a] -> [a] -> [a]
++ String
".tix")
    forall (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)

-- | Generates the HTML coverage report and shows a textual coverage summary for a package.

generateHpcReport :: HasEnvConfig env
                  => Path Abs Dir -> Package -> [Text] -> RIO env ()
generateHpcReport :: forall env.
HasEnvConfig env =>
Path Abs Dir -> Package -> [Text] -> RIO env ()
generateHpcReport Path Abs Dir
pkgDir Package
package [Text]
tests = do
    ActualCompiler
compilerVersion <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasSourceMap env => SimpleGetter env ActualCompiler
actualCompilerVersionL
    -- If we're using > GHC 7.10, the hpc 'include' parameter must specify a ghc package key. See

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

    let 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 <-
        -- Pre-7.8 uses plain PKG-version in tix files.

        if Version
ghcVersion forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
7, Int
10] then forall (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]
        -- We don't expect to find a package key if there is no library.

        else if Bool -> Bool
not Bool
hasLibrary Bool -> Bool -> Bool
&& forall a. Set a -> Bool
Set.null Set Text
internalLibs then forall (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
        -- Look in the inplace DB for the package key.

        -- See https://github.com/commercialhaskell/stack/issues/1181#issuecomment-148968986

        else do
            -- GHC 8.0 uses package id instead of package key.

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

            let hpcNameField :: Text
hpcNameField = if Version
ghcVersion forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
8, Int
0] then Text
"id" else Text
"key"
            Either Text [Text]
eincludeName <- forall env.
HasEnvConfig env =>
Path Abs Dir
-> PackageIdentifier
-> Set Text
-> Text
-> RIO env (Either Text [Text])
findPackageFieldForBuiltPackage Path Abs Dir
pkgDir (Package -> PackageIdentifier
packageIdentifier Package
package) Set Text
internalLibs Text
hpcNameField
            case Either Text [Text]
eincludeName of
                Left Text
err -> do
                    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Utf8Builder
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)))
            -- Restrict to just the current library code, if there is a library in the package (see

            -- #634 - this will likely be customizable in the future)

            Right Maybe [String]
mincludeName -> do
                let extraArgs :: [String]
extraArgs = case Maybe [String]
mincludeName of
                        Just [String]
includeNames -> String
"--include" 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
    -- If a .tix file exists, move it to the HPC output directory and generate a report for it.

    Bool
tixFileExists <- forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
tixSrc
    if Bool -> Bool
not Bool
tixFileExists
        then do
            forall (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
            -- Directories for .mix files.

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

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

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

                    [String
"--hpcdir", forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Rel Dir
hpcRelDir, String
"--reset-hpcdirs"]
            forall (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
                    -- Print output, stripping @\r@ characters because Windows.

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

                    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
String -> [String] -> (ProcessConfig () () () -> m a) -> m a
proc String
"hpc"
                        ( String
"markup"
                        forall a. a -> [a] -> [a]
: forall b t. Path b t -> String
toFilePath Path Abs File
tixSrc
                        forall a. a -> [a] -> [a]
: (String
"--destdir=" forall a. [a] -> [a] -> [a]
++ forall loc. Path loc Dir -> String
toFilePathNoTrailingSep Path Abs Dir
reportDir)
                        forall a. a -> [a] -> [a]
: ([String]
args forall a. [a] -> [a] -> [a]
++ [String]
extraMarkupArgs)
                        )
                        forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ByteString, ByteString)
readProcess_
                    forall (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 <-
         -- When there aren't any package component arguments, and --all

         -- isn't passed, default to not considering any targets.

         if Bool -> Bool
not (HpcReportOpts -> Bool
hroptsAll HpcReportOpts
opts) Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
targetNames
         then forall (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
-- Previously, the test below was:

--

--  if length tixFiles < 2

--      then logInfo $

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

--          " found in " <>

--          fromString (toFilePath outputDir) <>

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

--      else ...

--

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

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

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

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

--

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

-- even if may be redundant in some circumstances.

    if 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

-- | Module names which contain '/' have a package name, and so they weren't built into the

-- executable.

removeExeModules :: Tix -> Tix
removeExeModules :: Tix -> Tix
removeExeModules (Tix [TixModule]
ms) = [TixModule] -> Tix
Tix (forall a. (a -> Bool) -> [a] -> [a]
filter (\(TixModule String
name Hash
_ Int
_ [Integer]
_) -> Char
'/' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
name) [TixModule]
ms)

unionTixes :: [Tix] -> ([String], Tix)
unionTixes :: [Tix] -> ([String], Tix)
unionTixes [Tix]
tixes = (forall k a. Map k a -> [k]
Map.keys Map String ()
errs, [TixModule] -> Tix
Tix (forall k a. Map k a -> [a]
Map.elems Map String TixModule
outputs))
  where
    (Map String ()
errs, Map String TixModule
outputs) = forall a b c k. (a -> Either b c) -> Map k a -> (Map k b, Map k c)
Map.mapEither forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith forall {a} {a}.
Either a TixModule -> Either a TixModule -> Either () TixModule
merge forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Tix -> Map String (Either a TixModule)
toMap [Tix]
tixes
    toMap :: Tix -> Map String (Either a TixModule)
toMap (Tix [TixModule]
ms) = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall a b. (a -> b) -> [a] -> [b]
map (\x :: TixModule
x@(TixModule String
k Hash
_ Int
_ [Integer]
_) -> (String
k, forall a b. b -> Either a b
Right TixModule
x)) [TixModule]
ms)
    merge :: Either a TixModule -> Either a TixModule -> Either () TixModule
merge (Right (TixModule String
k Hash
hash1 Int
len1 [Integer]
tix1))
          (Right (TixModule String
_ Hash
hash2 Int
len2 [Integer]
tix2))
        | Hash
hash1 forall a. Eq a => a -> a -> Bool
== Hash
hash2 Bool -> Bool -> Bool
&& Int
len1 forall a. Eq a => a -> a -> Bool
== Int
len2 = forall a b. b -> Either a b
Right (String -> Hash -> Int -> [Integer] -> TixModule
TixModule String
k Hash
hash1 Int
len1 (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. Num a => a -> a -> a
(+) [Integer]
tix1 [Integer]
tix2))
    merge Either a TixModule
_ Either a TixModule
_ = forall a b. a -> Either a b
Left ()

generateHpcMarkupIndex :: HasEnvConfig env => RIO env ()
generateHpcMarkupIndex :: forall env. HasEnvConfig env => RIO env ()
generateHpcMarkupIndex = do
    Path Abs Dir
outputDir <- forall env. HasEnvConfig env => RIO env (Path Abs Dir)
hpcReportDir
    let outputFile :: Path Abs File
outputFile = Path Abs Dir
outputDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
relFileIndexHtml
    forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
outputDir
    ([Path Abs Dir]
dirs, [Path Abs File]
_) <- forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
outputDir
    [Text]
rows <- forall (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
<>
        -- Part of the css from HPC's output HTML

        Builder
"<style type=\"text/css\">" forall a. Semigroup a => a -> a -> a
<>
        Builder
"table.dashboard { border-collapse: collapse; border: solid 1px black }" forall a. Semigroup a => a -> a -> a
<>
        Builder
".dashboard td { border: solid 1px black }" forall a. Semigroup a => a -> a -> a
<>
        Builder
".dashboard th { border: solid 1px black }" forall a. Semigroup a => a -> a -> a
<>
        Builder
"</style>" forall a. Semigroup a => a -> a -> a
<>
        Builder
"</head>" forall a. Semigroup a => a -> a -> a
<>
        Builder
"<body>" forall a. Semigroup a => a -> a -> a
<>
        (if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
rows
            then
                Builder
"<b>No hpc_index.html files found in \"" forall a. Semigroup a => a -> a -> a
<>
                Text -> Builder
encodeUtf8Builder (forall b t. Path b t -> Text
pathToHtml Path Abs Dir
outputDir) forall a. Semigroup a => a -> a -> a
<>
                Builder
"\".</b>"
            else
                Builder
"<table class=\"dashboard\" width=\"100%\" border=\"1\"><tbody>" forall a. Semigroup a => a -> a -> a
<>
                Builder
"<p><b>NOTE: This is merely a listing of the html files found in the coverage reports directory.  Some of these reports may be old.</b></p>" forall a. Semigroup a => a -> a -> a
<>
                Builder
"<tr><th>Package</th><th>TestSuite</th><th>Modification Time</th></tr>" forall a. Semigroup a => a -> a -> a
<>
                forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Text -> Builder
encodeUtf8Builder [Text]
rows forall a. Semigroup a => a -> a -> a
<>
                Builder
"</tbody></table>") forall a. Semigroup a => a -> a -> a
<>
        Builder
"</body></html>"
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
rows) forall a b. (a -> b) -> a -> b
$
        forall env.
HasTerm env =>
StyleDoc -> 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

-- | Escape HTML symbols (copied from Text.Hastache)

htmlEscape :: LT.Text -> LT.Text
htmlEscape :: Text -> Text
htmlEscape = (Char -> Text) -> Text -> Text
LT.concatMap Char -> Text
proc_
  where
    proc_ :: Char -> Text
proc_ Char
'&'  = Text
"&amp;"
    proc_ Char
'\\' = Text
"&#92;"
    proc_ Char
'"'  = Text
"&quot;"
    proc_ Char
'\'' = Text
"&#39;"
    proc_ Char
'<'  = Text
"&lt;"
    proc_ Char
'>'  = Text
"&gt;"
    proc_ Char
h    = Char -> Text
LT.singleton Char
h

sanitize :: String -> Text
sanitize :: String -> Text
sanitize = Text -> Text
LT.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
htmlEscape forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
LT.pack

dirnameString :: Path r Dir -> String
dirnameString :: forall loc. Path loc Dir -> String
dirnameString = forall a. (a -> Bool) -> [a] -> [a]
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
            -- here we don't need to handle internal libs

            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
            -- With Cabal-1.24, it's in a different location.

            forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Scanning " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (forall b t. Path b t -> String
toFilePath Path Abs Dir
inplaceDir) forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" for files matching " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString String
pkgIdStr
            ([Path Abs Dir]
_, [Path Abs File]
files) <- forall (m :: * -> *) a.
MonadUnliftIO m =>
(IOException -> m a) -> m a -> m a
handleIO (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (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
            -- From all the files obtained from the scanning process above, we

            -- need to identify which are .conf files and then ensure that

            -- there is at most one .conf file for each library and internal

            -- library (some might be missing if that component has not been

            -- built yet). We should error if there are more than one .conf

            -- file for a component or if there are no .conf files at all in

            -- the searched location.

            let toFilename :: Path b File -> Text
toFilename = String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> String
toFilePath forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. Path b File -> Path Rel File
filename
                -- strip known prefix and suffix from the found files to determine only the conf files

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

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

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

                    [] -> 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]
findExtraTixFiles :: forall env. HasEnvConfig env => RIO env [Path Abs File]
findExtraTixFiles = do
    Path Abs Dir
outputDir <- forall env. HasEnvConfig env => RIO env (Path Abs Dir)
hpcReportDir
    let dir :: Path Abs Dir
dir = Path Abs Dir
outputDir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel Dir
relDirExtraTixFiles
    Bool
dirExists <- forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist Path Abs Dir
dir
    if Bool
dirExists
        then do
            ([Path Abs Dir]
_, [Path Abs File]
files) <- forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
dir
            forall (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 []