{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
module Distribution.Simple.Hpc
( Way (..)
, guessWay
, htmlDir
, mixDir
, tixDir
, tixFilePath
, HPCMarkupInfo (..)
, markupPackage
) where
import Distribution.Compat.Prelude
import Prelude ()
import Distribution.ModuleName (ModuleName, main)
import Distribution.PackageDescription
( TestSuite (..)
, testModules
)
import qualified Distribution.PackageDescription as PD
import Distribution.Pretty
import Distribution.Simple.LocalBuildInfo
( LocalBuildInfo (..)
, interpretSymbolicPathLBI
, mbWorkDirLBI
)
import Distribution.Simple.Program
( hpcProgram
, requireProgramVersion
)
import Distribution.Simple.Program.Hpc (markup, union)
import Distribution.Simple.Utils (notice)
import Distribution.Types.UnqualComponentName
import Distribution.Utils.Path
import Distribution.Verbosity (Verbosity ())
import Distribution.Version (anyVersion)
import System.Directory (createDirectoryIfMissing, doesFileExist)
data Way = Vanilla | Prof | Dyn | ProfDyn
deriving (Way
Way -> Way -> Bounded Way
forall a. a -> a -> Bounded a
$cminBound :: Way
minBound :: Way
$cmaxBound :: Way
maxBound :: Way
Bounded, Int -> Way
Way -> Int
Way -> [Way]
Way -> Way
Way -> Way -> [Way]
Way -> Way -> Way -> [Way]
(Way -> Way)
-> (Way -> Way)
-> (Int -> Way)
-> (Way -> Int)
-> (Way -> [Way])
-> (Way -> Way -> [Way])
-> (Way -> Way -> [Way])
-> (Way -> Way -> Way -> [Way])
-> Enum Way
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Way -> Way
succ :: Way -> Way
$cpred :: Way -> Way
pred :: Way -> Way
$ctoEnum :: Int -> Way
toEnum :: Int -> Way
$cfromEnum :: Way -> Int
fromEnum :: Way -> Int
$cenumFrom :: Way -> [Way]
enumFrom :: Way -> [Way]
$cenumFromThen :: Way -> Way -> [Way]
enumFromThen :: Way -> Way -> [Way]
$cenumFromTo :: Way -> Way -> [Way]
enumFromTo :: Way -> Way -> [Way]
$cenumFromThenTo :: Way -> Way -> Way -> [Way]
enumFromThenTo :: Way -> Way -> Way -> [Way]
Enum, Way -> Way -> Bool
(Way -> Way -> Bool) -> (Way -> Way -> Bool) -> Eq Way
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Way -> Way -> Bool
== :: Way -> Way -> Bool
$c/= :: Way -> Way -> Bool
/= :: Way -> Way -> Bool
Eq, ReadPrec [Way]
ReadPrec Way
Int -> ReadS Way
ReadS [Way]
(Int -> ReadS Way)
-> ReadS [Way] -> ReadPrec Way -> ReadPrec [Way] -> Read Way
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Way
readsPrec :: Int -> ReadS Way
$creadList :: ReadS [Way]
readList :: ReadS [Way]
$creadPrec :: ReadPrec Way
readPrec :: ReadPrec Way
$creadListPrec :: ReadPrec [Way]
readListPrec :: ReadPrec [Way]
Read, Int -> Way -> ShowS
[Way] -> ShowS
Way -> [Char]
(Int -> Way -> ShowS)
-> (Way -> [Char]) -> ([Way] -> ShowS) -> Show Way
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Way -> ShowS
showsPrec :: Int -> Way -> ShowS
$cshow :: Way -> [Char]
show :: Way -> [Char]
$cshowList :: [Way] -> ShowS
showList :: [Way] -> ShowS
Show)
hpcDir
:: SymbolicPath Pkg (Dir Dist)
-> Way
-> SymbolicPath Pkg (Dir Artifacts)
hpcDir :: SymbolicPathX 'AllowAbsolute Pkg ('Dir Dist)
-> Way -> SymbolicPathX 'AllowAbsolute Pkg ('Dir Artifacts)
hpcDir SymbolicPathX 'AllowAbsolute Pkg ('Dir Dist)
distPref Way
way = SymbolicPathX 'AllowAbsolute Pkg ('Dir Dist)
distPref SymbolicPathX 'AllowAbsolute Pkg ('Dir Dist)
-> SymbolicPathX 'OnlyRelative Dist ('Dir Artifacts)
-> SymbolicPathX 'AllowAbsolute Pkg ('Dir Artifacts)
forall p q r. PathLike p q r => p -> q -> r
</> [Char] -> SymbolicPathX 'OnlyRelative Dist ('Dir Artifacts)
forall from (to :: FileOrDir).
HasCallStack =>
[Char] -> RelativePath from to
makeRelativePathEx ([Char]
"hpc" [Char] -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> [Char]
wayDir)
where
wayDir :: [Char]
wayDir = case Way
way of
Way
Vanilla -> [Char]
"vanilla"
Way
Prof -> [Char]
"prof"
Way
Dyn -> [Char]
"dyn"
Way
ProfDyn -> [Char]
"prof_dyn"
mixDir
:: SymbolicPath Pkg (Dir Dist)
-> Way
-> SymbolicPath Pkg (Dir Mix)
mixDir :: SymbolicPathX 'AllowAbsolute Pkg ('Dir Dist)
-> Way -> SymbolicPathX 'AllowAbsolute Pkg ('Dir Mix)
mixDir SymbolicPathX 'AllowAbsolute Pkg ('Dir Dist)
distPref Way
way = SymbolicPathX 'AllowAbsolute Pkg ('Dir Dist)
-> Way -> SymbolicPathX 'AllowAbsolute Pkg ('Dir Artifacts)
hpcDir SymbolicPathX 'AllowAbsolute Pkg ('Dir Dist)
distPref Way
way SymbolicPathX 'AllowAbsolute Pkg ('Dir Artifacts)
-> SymbolicPathX 'OnlyRelative Artifacts ('Dir Mix)
-> SymbolicPathX 'AllowAbsolute Pkg ('Dir Mix)
forall p q r. PathLike p q r => p -> q -> r
</> [Char] -> SymbolicPathX 'OnlyRelative Artifacts ('Dir Mix)
forall from (to :: FileOrDir).
HasCallStack =>
[Char] -> RelativePath from to
makeRelativePathEx [Char]
"mix"
tixDir
:: SymbolicPath Pkg (Dir Dist)
-> Way
-> SymbolicPath Pkg (Dir Tix)
tixDir :: SymbolicPathX 'AllowAbsolute Pkg ('Dir Dist)
-> Way -> SymbolicPathX 'AllowAbsolute Pkg ('Dir Tix)
tixDir SymbolicPathX 'AllowAbsolute Pkg ('Dir Dist)
distPref Way
way = SymbolicPathX 'AllowAbsolute Pkg ('Dir Dist)
-> Way -> SymbolicPathX 'AllowAbsolute Pkg ('Dir Artifacts)
hpcDir SymbolicPathX 'AllowAbsolute Pkg ('Dir Dist)
distPref Way
way SymbolicPathX 'AllowAbsolute Pkg ('Dir Artifacts)
-> SymbolicPathX 'OnlyRelative Artifacts ('Dir Tix)
-> SymbolicPathX 'AllowAbsolute Pkg ('Dir Tix)
forall p q r. PathLike p q r => p -> q -> r
</> [Char] -> SymbolicPathX 'OnlyRelative Artifacts ('Dir Tix)
forall from (to :: FileOrDir).
HasCallStack =>
[Char] -> RelativePath from to
makeRelativePathEx [Char]
"tix"
tixFilePath
:: SymbolicPath Pkg (Dir Dist)
-> Way
-> FilePath
-> SymbolicPath Pkg File
tixFilePath :: SymbolicPathX 'AllowAbsolute Pkg ('Dir Dist)
-> Way -> [Char] -> SymbolicPathX 'AllowAbsolute Pkg 'File
tixFilePath SymbolicPathX 'AllowAbsolute Pkg ('Dir Dist)
distPref Way
way [Char]
name = SymbolicPathX 'AllowAbsolute Pkg ('Dir Dist)
-> Way -> SymbolicPathX 'AllowAbsolute Pkg ('Dir Tix)
tixDir SymbolicPathX 'AllowAbsolute Pkg ('Dir Dist)
distPref Way
way SymbolicPathX 'AllowAbsolute Pkg ('Dir Tix)
-> SymbolicPathX 'OnlyRelative Tix 'File
-> SymbolicPathX 'AllowAbsolute Pkg 'File
forall p q r. PathLike p q r => p -> q -> r
</> [Char] -> SymbolicPathX 'OnlyRelative Tix 'File
forall from (to :: FileOrDir).
HasCallStack =>
[Char] -> RelativePath from to
makeRelativePathEx ([Char]
name [Char] -> ShowS
forall p. FileLike p => p -> [Char] -> p
<.> [Char]
"tix")
htmlDir
:: SymbolicPath Pkg (Dir Dist)
-> Way
-> SymbolicPath Pkg (Dir Artifacts)
htmlDir :: SymbolicPathX 'AllowAbsolute Pkg ('Dir Dist)
-> Way -> SymbolicPathX 'AllowAbsolute Pkg ('Dir Artifacts)
htmlDir SymbolicPathX 'AllowAbsolute Pkg ('Dir Dist)
distPref Way
way = SymbolicPathX 'AllowAbsolute Pkg ('Dir Dist)
-> Way -> SymbolicPathX 'AllowAbsolute Pkg ('Dir Artifacts)
hpcDir SymbolicPathX 'AllowAbsolute Pkg ('Dir Dist)
distPref Way
way SymbolicPathX 'AllowAbsolute Pkg ('Dir Artifacts)
-> SymbolicPathX 'OnlyRelative Artifacts ('Dir Artifacts)
-> SymbolicPathX 'AllowAbsolute Pkg ('Dir Artifacts)
forall p q r. PathLike p q r => p -> q -> r
</> [Char] -> SymbolicPathX 'OnlyRelative Artifacts ('Dir Artifacts)
forall from (to :: FileOrDir).
HasCallStack =>
[Char] -> RelativePath from to
makeRelativePathEx [Char]
"html"
guessWay :: LocalBuildInfo -> Way
guessWay :: LocalBuildInfo -> Way
guessWay LocalBuildInfo
lbi
| LocalBuildInfo -> Bool
withProfExe LocalBuildInfo
lbi = Way
Prof
| LocalBuildInfo -> Bool
withDynExe LocalBuildInfo
lbi = Way
Dyn
| Bool
otherwise = Way
Vanilla
data HPCMarkupInfo = HPCMarkupInfo
{ HPCMarkupInfo
-> [SymbolicPathX 'AllowAbsolute Pkg ('Dir Artifacts)]
pathsToLibsArtifacts :: [SymbolicPath Pkg (Dir Artifacts)]
, HPCMarkupInfo -> [ModuleName]
libsModulesToInclude :: [ModuleName]
}
markupPackage
:: Verbosity
-> HPCMarkupInfo
-> LocalBuildInfo
-> SymbolicPath Pkg (Dir Dist)
-> PD.PackageDescription
-> [TestSuite]
-> IO ()
markupPackage :: Verbosity
-> HPCMarkupInfo
-> LocalBuildInfo
-> SymbolicPathX 'AllowAbsolute Pkg ('Dir Dist)
-> PackageDescription
-> [TestSuite]
-> IO ()
markupPackage Verbosity
verbosity HPCMarkupInfo{[SymbolicPathX 'AllowAbsolute Pkg ('Dir Artifacts)]
pathsToLibsArtifacts :: HPCMarkupInfo
-> [SymbolicPathX 'AllowAbsolute Pkg ('Dir Artifacts)]
pathsToLibsArtifacts :: [SymbolicPathX 'AllowAbsolute Pkg ('Dir Artifacts)]
pathsToLibsArtifacts, [ModuleName]
libsModulesToInclude :: HPCMarkupInfo -> [ModuleName]
libsModulesToInclude :: [ModuleName]
libsModulesToInclude} LocalBuildInfo
lbi SymbolicPathX 'AllowAbsolute Pkg ('Dir Dist)
testDistPref PackageDescription
pkg_descr [TestSuite]
suites = do
let tixFiles :: [SymbolicPathX 'AllowAbsolute Pkg 'File]
tixFiles = ([Char] -> SymbolicPathX 'AllowAbsolute Pkg 'File)
-> [[Char]] -> [SymbolicPathX 'AllowAbsolute Pkg 'File]
forall a b. (a -> b) -> [a] -> [b]
map (SymbolicPathX 'AllowAbsolute Pkg ('Dir Dist)
-> Way -> [Char] -> SymbolicPathX 'AllowAbsolute Pkg 'File
tixFilePath SymbolicPathX 'AllowAbsolute Pkg ('Dir Dist)
testDistPref Way
way) [[Char]]
testNames
mbWorkDir :: Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir = LocalBuildInfo -> Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDirLBI LocalBuildInfo
lbi
i :: SymbolicPathX allowAbsolute Pkg to -> [Char]
i = LocalBuildInfo -> SymbolicPathX allowAbsolute Pkg to -> [Char]
forall (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
LocalBuildInfo -> SymbolicPathX allowAbsolute Pkg to -> [Char]
interpretSymbolicPathLBI LocalBuildInfo
lbi
tixFilesExist <- (SymbolicPathX 'AllowAbsolute Pkg 'File -> IO Bool)
-> [SymbolicPathX 'AllowAbsolute Pkg 'File] -> IO [Bool]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ([Char] -> IO Bool
doesFileExist ([Char] -> IO Bool)
-> (SymbolicPathX 'AllowAbsolute Pkg 'File -> [Char])
-> SymbolicPathX 'AllowAbsolute Pkg 'File
-> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymbolicPathX 'AllowAbsolute Pkg 'File -> [Char]
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> [Char]
i) [SymbolicPathX 'AllowAbsolute Pkg 'File]
tixFiles
when (and tixFilesExist) $ do
(hpc, hpcVer, _) <-
requireProgramVersion
verbosity
hpcProgram
anyVersion
(withPrograms lbi)
let htmlDir' = SymbolicPathX 'AllowAbsolute Pkg ('Dir Dist)
-> Way -> SymbolicPathX 'AllowAbsolute Pkg ('Dir Artifacts)
htmlDir SymbolicPathX 'AllowAbsolute Pkg ('Dir Dist)
testDistPref Way
way
tixFile <- case suites of
[TestSuite
oneTest] -> do
let testName' :: [Char]
testName' = UnqualComponentName -> [Char]
unUnqualComponentName (UnqualComponentName -> [Char]) -> UnqualComponentName -> [Char]
forall a b. (a -> b) -> a -> b
$ TestSuite -> UnqualComponentName
testName TestSuite
oneTest
SymbolicPathX 'AllowAbsolute Pkg 'File
-> IO (SymbolicPathX 'AllowAbsolute Pkg 'File)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SymbolicPathX 'AllowAbsolute Pkg 'File
-> IO (SymbolicPathX 'AllowAbsolute Pkg 'File))
-> SymbolicPathX 'AllowAbsolute Pkg 'File
-> IO (SymbolicPathX 'AllowAbsolute Pkg 'File)
forall a b. (a -> b) -> a -> b
$
SymbolicPathX 'AllowAbsolute Pkg ('Dir Dist)
-> Way -> [Char] -> SymbolicPathX 'AllowAbsolute Pkg 'File
tixFilePath SymbolicPathX 'AllowAbsolute Pkg ('Dir Dist)
testDistPref Way
way [Char]
testName'
[TestSuite]
_ -> do
let excluded :: [ModuleName]
excluded = (TestSuite -> [ModuleName]) -> [TestSuite] -> [ModuleName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TestSuite -> [ModuleName]
testModules [TestSuite]
suites [ModuleName] -> [ModuleName] -> [ModuleName]
forall a. [a] -> [a] -> [a]
++ [ModuleName
main]
pkgName :: [Char]
pkgName = PackageIdentifier -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow (PackageIdentifier -> [Char]) -> PackageIdentifier -> [Char]
forall a b. (a -> b) -> a -> b
$ PackageDescription -> PackageIdentifier
PD.package PackageDescription
pkg_descr
summedTixFile :: SymbolicPathX 'AllowAbsolute Pkg 'File
summedTixFile = SymbolicPathX 'AllowAbsolute Pkg ('Dir Dist)
-> Way -> [Char] -> SymbolicPathX 'AllowAbsolute Pkg 'File
tixFilePath SymbolicPathX 'AllowAbsolute Pkg ('Dir Dist)
testDistPref Way
way [Char]
pkgName
Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ SymbolicPathX 'AllowAbsolute Pkg ('Dir (ZonkAny 0)) -> [Char]
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> [Char]
i (SymbolicPathX 'AllowAbsolute Pkg ('Dir (ZonkAny 0)) -> [Char])
-> SymbolicPathX 'AllowAbsolute Pkg ('Dir (ZonkAny 0)) -> [Char]
forall a b. (a -> b) -> a -> b
$ SymbolicPathX 'AllowAbsolute Pkg 'File
-> SymbolicPathX 'AllowAbsolute Pkg ('Dir (ZonkAny 0))
forall (allowAbsolute :: AllowAbsolute) from to'.
SymbolicPathX allowAbsolute from 'File
-> SymbolicPathX allowAbsolute from ('Dir to')
takeDirectorySymbolicPath SymbolicPathX 'AllowAbsolute Pkg 'File
summedTixFile
Maybe (SymbolicPath CWD ('Dir Pkg))
-> ConfiguredProgram
-> Verbosity
-> [SymbolicPathX 'AllowAbsolute Pkg 'File]
-> SymbolicPathX 'AllowAbsolute Pkg 'File
-> [ModuleName]
-> IO ()
union Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir ConfiguredProgram
hpc Verbosity
verbosity [SymbolicPathX 'AllowAbsolute Pkg 'File]
tixFiles SymbolicPathX 'AllowAbsolute Pkg 'File
summedTixFile [ModuleName]
excluded
SymbolicPathX 'AllowAbsolute Pkg 'File
-> IO (SymbolicPathX 'AllowAbsolute Pkg 'File)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SymbolicPathX 'AllowAbsolute Pkg 'File
summedTixFile
markup mbWorkDir hpc hpcVer verbosity tixFile mixDirs htmlDir' libsModulesToInclude
notice verbosity $
"Package coverage report written to "
++ i htmlDir'
</> "hpc_index.html"
where
way :: Way
way = LocalBuildInfo -> Way
guessWay LocalBuildInfo
lbi
testNames :: [[Char]]
testNames = (TestSuite -> [Char]) -> [TestSuite] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (UnqualComponentName -> [Char]
unUnqualComponentName (UnqualComponentName -> [Char])
-> (TestSuite -> UnqualComponentName) -> TestSuite -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestSuite -> UnqualComponentName
testName) [TestSuite]
suites
mixDirs :: [SymbolicPathX 'AllowAbsolute Pkg ('Dir Mix)]
mixDirs = (SymbolicPathX 'AllowAbsolute Pkg ('Dir Artifacts)
-> SymbolicPathX 'AllowAbsolute Pkg ('Dir Mix))
-> [SymbolicPathX 'AllowAbsolute Pkg ('Dir Artifacts)]
-> [SymbolicPathX 'AllowAbsolute Pkg ('Dir Mix)]
forall a b. (a -> b) -> [a] -> [b]
map ((SymbolicPathX 'AllowAbsolute Pkg ('Dir Dist)
-> Way -> SymbolicPathX 'AllowAbsolute Pkg ('Dir Mix)
`mixDir` Way
way) (SymbolicPathX 'AllowAbsolute Pkg ('Dir Dist)
-> SymbolicPathX 'AllowAbsolute Pkg ('Dir Mix))
-> (SymbolicPathX 'AllowAbsolute Pkg ('Dir Artifacts)
-> SymbolicPathX 'AllowAbsolute Pkg ('Dir Dist))
-> SymbolicPathX 'AllowAbsolute Pkg ('Dir Artifacts)
-> SymbolicPathX 'AllowAbsolute Pkg ('Dir Mix)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymbolicPathX 'AllowAbsolute Pkg ('Dir Artifacts)
-> SymbolicPathX 'AllowAbsolute Pkg ('Dir Dist)
forall (allowAbsolute :: AllowAbsolute) from (to1 :: FileOrDir)
(to2 :: FileOrDir).
SymbolicPathX allowAbsolute from to1
-> SymbolicPathX allowAbsolute from to2
coerceSymbolicPath) [SymbolicPathX 'AllowAbsolute Pkg ('Dir Artifacts)]
pathsToLibsArtifacts