{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}

-----------------------------------------------------------------------------

-- |
-- Module      :  Distribution.Simple.Hpc
-- Copyright   :  Thomas Tuegel 2011
-- License     :  BSD3
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- This module provides functions for locating various HPC-related paths and
-- a function for adding the necessary options to a PackageDescription to
-- build test suites with HPC enabled.
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)

-- -------------------------------------------------------------------------
-- Haskell Program Coverage

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 -> String
(Int -> Way -> ShowS)
-> (Way -> String) -> ([Way] -> ShowS) -> Show Way
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Way -> ShowS
showsPrec :: Int -> Way -> ShowS
$cshow :: Way -> String
show :: Way -> String
$cshowList :: [Way] -> ShowS
showList :: [Way] -> ShowS
Show)

hpcDir
  :: SymbolicPath Pkg (Dir Dist)
  -- ^ \"dist/\" prefix
  -> Way
  -> SymbolicPath Pkg (Dir Artifacts)
  -- ^ Directory containing component's HPC .mix files
hpcDir :: SymbolicPath Pkg ('Dir Dist)
-> Way -> SymbolicPath Pkg ('Dir Artifacts)
hpcDir SymbolicPath Pkg ('Dir Dist)
distPref Way
way = SymbolicPath Pkg ('Dir Dist)
distPref SymbolicPath Pkg ('Dir Dist)
-> RelativePath Dist ('Dir Artifacts)
-> SymbolicPath Pkg ('Dir Artifacts)
forall p q r. PathLike p q r => p -> q -> r
</> String -> RelativePath Dist ('Dir Artifacts)
forall from (to :: FileOrDir).
HasCallStack =>
String -> RelativePath from to
makeRelativePathEx (String
"hpc" String -> ShowS
forall p q r. PathLike p q r => p -> q -> r
</> String
wayDir)
  where
    wayDir :: String
wayDir = case Way
way of
      Way
Vanilla -> String
"vanilla"
      Way
Prof -> String
"prof"
      Way
Dyn -> String
"dyn"
      Way
ProfDyn -> String
"prof_dyn"

mixDir
  :: SymbolicPath Pkg (Dir Dist)
  -- ^ \"dist/\" prefix
  -> Way
  -> SymbolicPath Pkg (Dir Mix)
  -- ^ Directory containing test suite's .mix files
mixDir :: SymbolicPath Pkg ('Dir Dist) -> Way -> SymbolicPath Pkg ('Dir Mix)
mixDir SymbolicPath Pkg ('Dir Dist)
distPref Way
way = SymbolicPath Pkg ('Dir Dist)
-> Way -> SymbolicPath Pkg ('Dir Artifacts)
hpcDir SymbolicPath Pkg ('Dir Dist)
distPref Way
way SymbolicPath Pkg ('Dir Artifacts)
-> RelativePath Artifacts ('Dir Mix) -> SymbolicPath Pkg ('Dir Mix)
forall p q r. PathLike p q r => p -> q -> r
</> String -> RelativePath Artifacts ('Dir Mix)
forall from (to :: FileOrDir).
HasCallStack =>
String -> RelativePath from to
makeRelativePathEx String
"mix"

tixDir
  :: SymbolicPath Pkg (Dir Dist)
  -- ^ \"dist/\" prefix
  -> Way
  -> SymbolicPath Pkg (Dir Tix)
  -- ^ Directory containing test suite's .tix files
tixDir :: SymbolicPath Pkg ('Dir Dist) -> Way -> SymbolicPath Pkg ('Dir Tix)
tixDir SymbolicPath Pkg ('Dir Dist)
distPref Way
way = SymbolicPath Pkg ('Dir Dist)
-> Way -> SymbolicPath Pkg ('Dir Artifacts)
hpcDir SymbolicPath Pkg ('Dir Dist)
distPref Way
way SymbolicPath Pkg ('Dir Artifacts)
-> RelativePath Artifacts ('Dir Tix) -> SymbolicPath Pkg ('Dir Tix)
forall p q r. PathLike p q r => p -> q -> r
</> String -> RelativePath Artifacts ('Dir Tix)
forall from (to :: FileOrDir).
HasCallStack =>
String -> RelativePath from to
makeRelativePathEx String
"tix"

-- | Path to the .tix file containing a test suite's sum statistics.
tixFilePath
  :: SymbolicPath Pkg (Dir Dist)
  -- ^ \"dist/\" prefix
  -> Way
  -> FilePath
  -- ^ Component name
  -> SymbolicPath Pkg File
  -- ^ Path to test suite's .tix file
tixFilePath :: SymbolicPath Pkg ('Dir Dist)
-> Way -> String -> SymbolicPath Pkg 'File
tixFilePath SymbolicPath Pkg ('Dir Dist)
distPref Way
way String
name = SymbolicPath Pkg ('Dir Dist) -> Way -> SymbolicPath Pkg ('Dir Tix)
tixDir SymbolicPath Pkg ('Dir Dist)
distPref Way
way SymbolicPath Pkg ('Dir Tix)
-> RelativePath Tix 'File -> SymbolicPath Pkg 'File
forall p q r. PathLike p q r => p -> q -> r
</> String -> RelativePath Tix 'File
forall from (to :: FileOrDir).
HasCallStack =>
String -> RelativePath from to
makeRelativePathEx (String
name String -> ShowS
forall p. FileLike p => p -> String -> p
<.> String
"tix")

htmlDir
  :: SymbolicPath Pkg (Dir Dist)
  -- ^ \"dist/\" prefix
  -> Way
  -> SymbolicPath Pkg (Dir Artifacts)
  -- ^ Path to test suite's HTML markup directory
htmlDir :: SymbolicPath Pkg ('Dir Dist)
-> Way -> SymbolicPath Pkg ('Dir Artifacts)
htmlDir SymbolicPath Pkg ('Dir Dist)
distPref Way
way = SymbolicPath Pkg ('Dir Dist)
-> Way -> SymbolicPath Pkg ('Dir Artifacts)
hpcDir SymbolicPath Pkg ('Dir Dist)
distPref Way
way SymbolicPath Pkg ('Dir Artifacts)
-> RelativePath Artifacts ('Dir Artifacts)
-> SymbolicPath Pkg ('Dir Artifacts)
forall p q r. PathLike p q r => p -> q -> r
</> String -> RelativePath Artifacts ('Dir Artifacts)
forall from (to :: FileOrDir).
HasCallStack =>
String -> RelativePath from to
makeRelativePathEx String
"html"

-- | Attempt to guess the way the test suites in this package were compiled
-- and linked with the library so the correct module interfaces are found.
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

-- | Haskell Program Coverage information required to produce a valid HPC
-- report through the `hpc markup` call for the package libraries.
data HPCMarkupInfo = HPCMarkupInfo
  { HPCMarkupInfo -> [SymbolicPath Pkg ('Dir Artifacts)]
pathsToLibsArtifacts :: [SymbolicPath Pkg (Dir Artifacts)]
  -- ^ The paths to the library components whose modules are included in the
  -- coverage report
  , HPCMarkupInfo -> [ModuleName]
libsModulesToInclude :: [ModuleName]
  -- ^ The modules to include in the coverage report
  }

-- | Generate the HTML markup for a package's test suites.
markupPackage
  :: Verbosity
  -> HPCMarkupInfo
  -> LocalBuildInfo
  -> SymbolicPath Pkg (Dir Dist)
  -- ^ Testsuite \"dist/\" prefix
  -> PD.PackageDescription
  -> [TestSuite]
  -> IO ()
markupPackage :: Verbosity
-> HPCMarkupInfo
-> LocalBuildInfo
-> SymbolicPath Pkg ('Dir Dist)
-> PackageDescription
-> [TestSuite]
-> IO ()
markupPackage Verbosity
verbosity HPCMarkupInfo{[SymbolicPath Pkg ('Dir Artifacts)]
pathsToLibsArtifacts :: HPCMarkupInfo -> [SymbolicPath Pkg ('Dir Artifacts)]
pathsToLibsArtifacts :: [SymbolicPath Pkg ('Dir Artifacts)]
pathsToLibsArtifacts, [ModuleName]
libsModulesToInclude :: HPCMarkupInfo -> [ModuleName]
libsModulesToInclude :: [ModuleName]
libsModulesToInclude} LocalBuildInfo
lbi SymbolicPath Pkg ('Dir Dist)
testDistPref PackageDescription
pkg_descr [TestSuite]
suites = do
  let tixFiles :: [SymbolicPath Pkg 'File]
tixFiles = (String -> SymbolicPath Pkg 'File)
-> [String] -> [SymbolicPath Pkg 'File]
forall a b. (a -> b) -> [a] -> [b]
map (SymbolicPath Pkg ('Dir Dist)
-> Way -> String -> SymbolicPath Pkg 'File
tixFilePath SymbolicPath Pkg ('Dir Dist)
testDistPref Way
way) [String]
testNames
      mbWorkDir :: Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir = LocalBuildInfo -> Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDirLBI LocalBuildInfo
lbi
      i :: SymbolicPathX allowAbsolute Pkg to -> String
i = LocalBuildInfo -> SymbolicPathX allowAbsolute Pkg to -> String
forall (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
LocalBuildInfo -> SymbolicPathX allowAbsolute Pkg to -> String
interpretSymbolicPathLBI LocalBuildInfo
lbi -- See Note [Symbolic paths] in Distribution.Utils.Path
  tixFilesExist <- (SymbolicPath Pkg 'File -> IO Bool)
-> [SymbolicPath 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 (String -> IO Bool
doesFileExist (String -> IO Bool)
-> (SymbolicPath Pkg 'File -> String)
-> SymbolicPath Pkg 'File
-> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymbolicPath Pkg 'File -> String
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> String
i) [SymbolicPath Pkg 'File]
tixFiles
  when (and tixFilesExist) $ do
    -- behaviour of 'markup' depends on version, so we need *a* version
    -- but no particular one
    (hpc, hpcVer, _) <-
      requireProgramVersion
        verbosity
        hpcProgram
        anyVersion
        (withPrograms lbi)
    let htmlDir' = SymbolicPath Pkg ('Dir Dist)
-> Way -> SymbolicPath Pkg ('Dir Artifacts)
htmlDir SymbolicPath Pkg ('Dir Dist)
testDistPref Way
way
    -- The tix file used to generate the report is either the testsuite's
    -- tix file, when there is only one testsuite, or the sum of the tix
    -- files of all testsuites in the package, which gets put under pkgName
    -- for this component (a bit weird)
    -- TODO: cabal-install should pass to Cabal where to put the summed tix
    -- and report, and perhaps even the testsuites from other packages in
    -- the project which are currently not accounted for in the summed
    -- report.
    tixFile <- case suites of
      -- We call 'markupPackage' once for each testsuite to run individually,
      -- to get the coverage report of just the one testsuite
      [TestSuite
oneTest] -> do
        let testName' :: String
testName' = UnqualComponentName -> String
unUnqualComponentName (UnqualComponentName -> String) -> UnqualComponentName -> String
forall a b. (a -> b) -> a -> b
$ TestSuite -> UnqualComponentName
testName TestSuite
oneTest
        SymbolicPath Pkg 'File -> IO (SymbolicPath Pkg 'File)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SymbolicPath Pkg 'File -> IO (SymbolicPath Pkg 'File))
-> SymbolicPath Pkg 'File -> IO (SymbolicPath Pkg 'File)
forall a b. (a -> b) -> a -> b
$
          SymbolicPath Pkg ('Dir Dist)
-> Way -> String -> SymbolicPath Pkg 'File
tixFilePath SymbolicPath Pkg ('Dir Dist)
testDistPref Way
way String
testName'
      -- And call 'markupPackage' once per `test` invocation with all the
      -- testsuites to run, which results in multiple tix files being considered
      [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 :: String
pkgName = PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow (PackageIdentifier -> String) -> PackageIdentifier -> String
forall a b. (a -> b) -> a -> b
$ PackageDescription -> PackageIdentifier
PD.package PackageDescription
pkg_descr
            summedTixFile :: SymbolicPath Pkg 'File
summedTixFile = SymbolicPath Pkg ('Dir Dist)
-> Way -> String -> SymbolicPath Pkg 'File
tixFilePath SymbolicPath Pkg ('Dir Dist)
testDistPref Way
way String
pkgName
        Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ SymbolicPathX 'AllowAbsolute Pkg ('Dir (ZonkAny 0)) -> String
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> String
i (SymbolicPathX 'AllowAbsolute Pkg ('Dir (ZonkAny 0)) -> String)
-> SymbolicPathX 'AllowAbsolute Pkg ('Dir (ZonkAny 0)) -> String
forall a b. (a -> b) -> a -> b
$ SymbolicPath Pkg 'File
-> SymbolicPathX 'AllowAbsolute Pkg ('Dir (ZonkAny 0))
forall (allowAbsolute :: AllowAbsolute) from to'.
SymbolicPathX allowAbsolute from 'File
-> SymbolicPathX allowAbsolute from ('Dir to')
takeDirectorySymbolicPath SymbolicPath Pkg 'File
summedTixFile
        Maybe (SymbolicPath CWD ('Dir Pkg))
-> ConfiguredProgram
-> Verbosity
-> [SymbolicPath Pkg 'File]
-> SymbolicPath Pkg 'File
-> [ModuleName]
-> IO ()
union Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir ConfiguredProgram
hpc Verbosity
verbosity [SymbolicPath Pkg 'File]
tixFiles SymbolicPath Pkg 'File
summedTixFile [ModuleName]
excluded
        SymbolicPath Pkg 'File -> IO (SymbolicPath Pkg 'File)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SymbolicPath 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 :: [String]
testNames = (TestSuite -> String) -> [TestSuite] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (UnqualComponentName -> String
unUnqualComponentName (UnqualComponentName -> String)
-> (TestSuite -> UnqualComponentName) -> TestSuite -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestSuite -> UnqualComponentName
testName) [TestSuite]
suites
    mixDirs :: [SymbolicPath Pkg ('Dir Mix)]
mixDirs = (SymbolicPath Pkg ('Dir Artifacts) -> SymbolicPath Pkg ('Dir Mix))
-> [SymbolicPath Pkg ('Dir Artifacts)]
-> [SymbolicPath Pkg ('Dir Mix)]
forall a b. (a -> b) -> [a] -> [b]
map ((SymbolicPath Pkg ('Dir Dist) -> Way -> SymbolicPath Pkg ('Dir Mix)
`mixDir` Way
way) (SymbolicPath Pkg ('Dir Dist) -> SymbolicPath Pkg ('Dir Mix))
-> (SymbolicPath Pkg ('Dir Artifacts)
    -> SymbolicPath Pkg ('Dir Dist))
-> SymbolicPath Pkg ('Dir Artifacts)
-> SymbolicPath Pkg ('Dir Mix)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymbolicPath Pkg ('Dir Artifacts) -> SymbolicPath Pkg ('Dir Dist)
forall (allowAbsolute :: AllowAbsolute) from (to1 :: FileOrDir)
       (to2 :: FileOrDir).
SymbolicPathX allowAbsolute from to1
-> SymbolicPathX allowAbsolute from to2
coerceSymbolicPath) [SymbolicPath Pkg ('Dir Artifacts)]
pathsToLibsArtifacts