module Distribution.Simple.Hpc
( Way(..), guessWay
, htmlDir
, mixDir
, tixDir
, tixFilePath
, markupPackage
, markupTest
) where
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Types.UnqualComponentName
import Distribution.ModuleName ( main )
import qualified Distribution.PackageDescription as PD
import Distribution.PackageDescription
( Library(..)
, TestSuite(..)
, testModules
)
import Distribution.Pretty
import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) )
import Distribution.Simple.Program
( hpcProgram
, requireProgramVersion
)
import Distribution.Simple.Program.Hpc ( markup, union )
import Distribution.Simple.Utils ( notice )
import Distribution.Version ( anyVersion )
import Distribution.Verbosity ( Verbosity() )
import System.Directory ( createDirectoryIfMissing, doesFileExist )
import System.FilePath
data Way = Vanilla | Prof | Dyn
deriving (Bounded, Enum, Eq, Read, Show)
hpcDir :: FilePath
-> Way
-> FilePath
hpcDir distPref way = distPref </> "hpc" </> wayDir
where
wayDir = case way of
Vanilla -> "vanilla"
Prof -> "prof"
Dyn -> "dyn"
mixDir :: FilePath
-> Way
-> FilePath
-> FilePath
mixDir distPref way name = hpcDir distPrefBuild way </> "mix" </> name
where
distPrefElements = splitDirectories distPref
distPrefBuild = case drop (length distPrefElements 3) distPrefElements of
["t", _, "noopt"] ->
joinPath $ take (length distPrefElements 3) distPrefElements
++ ["noopt"]
["t", _, "opt"] ->
joinPath $ take (length distPrefElements 3) distPrefElements
++ ["opt"]
[_, "t", _] ->
joinPath $ take (length distPrefElements 2) distPrefElements
_ -> distPref
tixDir :: FilePath
-> Way
-> FilePath
-> FilePath
tixDir distPref way name = hpcDir distPref way </> "tix" </> name
tixFilePath :: FilePath
-> Way
-> FilePath
-> FilePath
tixFilePath distPref way name = tixDir distPref way name </> name <.> "tix"
htmlDir :: FilePath
-> Way
-> FilePath
-> FilePath
htmlDir distPref way name = hpcDir distPref way </> "html" </> name
guessWay :: LocalBuildInfo -> Way
guessWay lbi
| withProfExe lbi = Prof
| withDynExe lbi = Dyn
| otherwise = Vanilla
markupTest :: Verbosity
-> LocalBuildInfo
-> FilePath
-> String
-> TestSuite
-> Library
-> IO ()
markupTest verbosity lbi distPref libraryName suite library = do
tixFileExists <- doesFileExist $ tixFilePath distPref way $ testName'
when tixFileExists $ do
(hpc, hpcVer, _) <- requireProgramVersion verbosity
hpcProgram anyVersion (withPrograms lbi)
let htmlDir_ = htmlDir distPref way testName'
markup hpc hpcVer verbosity
(tixFilePath distPref way testName') mixDirs
htmlDir_
(exposedModules library)
notice verbosity $ "Test coverage report written to "
++ htmlDir_ </> "hpc_index" <.> "html"
where
way = guessWay lbi
testName' = unUnqualComponentName $ testName suite
mixDirs = map (mixDir distPref way) [ testName', libraryName ]
markupPackage :: Verbosity
-> LocalBuildInfo
-> FilePath
-> PD.PackageDescription
-> [TestSuite]
-> IO ()
markupPackage verbosity lbi distPref pkg_descr suites = do
let tixFiles = map (tixFilePath distPref way) testNames
tixFilesExist <- traverse doesFileExist tixFiles
when (and tixFilesExist) $ do
(hpc, hpcVer, _) <- requireProgramVersion verbosity
hpcProgram anyVersion (withPrograms lbi)
let outFile = tixFilePath distPref way libraryName
htmlDir' = htmlDir distPref way libraryName
excluded = concatMap testModules suites ++ [ main ]
createDirectoryIfMissing True $ takeDirectory outFile
union hpc verbosity tixFiles outFile excluded
markup hpc hpcVer verbosity outFile mixDirs htmlDir' included
notice verbosity $ "Package coverage report written to "
++ htmlDir' </> "hpc_index.html"
where
way = guessWay lbi
testNames = fmap (unUnqualComponentName . testName) suites
mixDirs = map (mixDir distPref way) $ libraryName : testNames
included = concatMap (exposedModules) $ PD.allLibraries pkg_descr
libraryName = prettyShow $ PD.package pkg_descr