{-# LANGUAGE FlexibleContexts #-}
{-# 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
  , markupPackage
  , markupTest
  ) where

import Distribution.Compat.Prelude
import Prelude ()

import Distribution.ModuleName (main)
import Distribution.PackageDescription
  ( Library (..)
  , TestSuite (..)
  , testModules
  )
import qualified Distribution.PackageDescription as PD
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.Types.UnqualComponentName
import Distribution.Verbosity (Verbosity ())
import Distribution.Version (anyVersion)
import System.Directory (createDirectoryIfMissing, doesFileExist)
import System.FilePath

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

data Way = Vanilla | Prof | Dyn
  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
  :: FilePath
  -- ^ \"dist/\" prefix
  -> Way
  -> FilePath
  -- ^ Directory containing component's HPC .mix files
hpcDir :: String -> Way -> String
hpcDir String
distPref Way
way = String
distPref String -> ShowS
</> String
"hpc" String -> ShowS
</> String
wayDir
  where
    wayDir :: String
wayDir = case Way
way of
      Way
Vanilla -> String
"vanilla"
      Way
Prof -> String
"prof"
      Way
Dyn -> String
"dyn"

mixDir
  :: FilePath
  -- ^ \"dist/\" prefix
  -> Way
  -> FilePath
  -- ^ Component name
  -> FilePath
  -- ^ Directory containing test suite's .mix files
mixDir :: String -> Way -> ShowS
mixDir String
distPref Way
way String
name = String -> Way -> String
hpcDir String
distPrefBuild Way
way String -> ShowS
</> String
"mix" String -> ShowS
</> String
name
  where
    -- This is a hack for HPC over test suites, needed to match the directory
    -- where HPC saves and reads .mix files when the main library of the same
    -- package is being processed, perhaps in a previous cabal run (#5213).
    -- E.g., @distPref@ may be
    -- @./dist-newstyle/build/x86_64-linux/ghc-9.0.1/cabal-gh5213-0.1/t/tests@
    -- but the path where library mix files reside has two less components
    -- at the end (@t/tests@) and this reduced path needs to be passed to
    -- both @hpc@ and @ghc@. For non-default optimization levels, the path
    -- suffix is one element longer and the extra path element needs
    -- to be preserved.
    distPrefElements :: [String]
distPrefElements = String -> [String]
splitDirectories String
distPref
    distPrefBuild :: String
distPrefBuild = case Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop ([String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
distPrefElements Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3) [String]
distPrefElements of
      [String
"t", String
_, String
"noopt"] ->
        [String] -> String
joinPath ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
          Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take ([String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
distPrefElements Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3) [String]
distPrefElements
            [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"noopt"]
      [String
"t", String
_, String
"opt"] ->
        [String] -> String
joinPath ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
          Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take ([String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
distPrefElements Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3) [String]
distPrefElements
            [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"opt"]
      [String
_, String
"t", String
_] ->
        [String] -> String
joinPath ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take ([String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
distPrefElements Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) [String]
distPrefElements
      [String]
_ -> String
distPref

tixDir
  :: FilePath
  -- ^ \"dist/\" prefix
  -> Way
  -> FilePath
  -- ^ Component name
  -> FilePath
  -- ^ Directory containing test suite's .tix files
tixDir :: String -> Way -> ShowS
tixDir String
distPref Way
way String
name = String -> Way -> String
hpcDir String
distPref Way
way String -> ShowS
</> String
"tix" String -> ShowS
</> String
name

-- | Path to the .tix file containing a test suite's sum statistics.
tixFilePath
  :: FilePath
  -- ^ \"dist/\" prefix
  -> Way
  -> FilePath
  -- ^ Component name
  -> FilePath
  -- ^ Path to test suite's .tix file
tixFilePath :: String -> Way -> ShowS
tixFilePath String
distPref Way
way String
name = String -> Way -> ShowS
tixDir String
distPref Way
way String
name String -> ShowS
</> String
name String -> ShowS
<.> String
"tix"

htmlDir
  :: FilePath
  -- ^ \"dist/\" prefix
  -> Way
  -> FilePath
  -- ^ Component name
  -> FilePath
  -- ^ Path to test suite's HTML markup directory
htmlDir :: String -> Way -> ShowS
htmlDir String
distPref Way
way String
name = String -> Way -> String
hpcDir String
distPref Way
way String -> ShowS
</> String
"html" String -> ShowS
</> String
name

-- | 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

-- | Generate the HTML markup for a test suite.
markupTest
  :: Verbosity
  -> LocalBuildInfo
  -> FilePath
  -- ^ \"dist/\" prefix
  -> String
  -- ^ Library name
  -> TestSuite
  -> Library
  -> IO ()
markupTest :: Verbosity
-> LocalBuildInfo
-> String
-> String
-> TestSuite
-> Library
-> IO ()
markupTest Verbosity
verbosity LocalBuildInfo
lbi String
distPref String
libraryName TestSuite
suite Library
library = do
  Bool
tixFileExists <- String -> IO Bool
doesFileExist (String -> IO Bool) -> String -> IO Bool
forall a b. (a -> b) -> a -> b
$ String -> Way -> ShowS
tixFilePath String
distPref Way
way ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
testName'
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tixFileExists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    -- behaviour of 'markup' depends on version, so we need *a* version
    -- but no particular one
    (ConfiguredProgram
hpc, Version
hpcVer, ProgramDb
_) <-
      Verbosity
-> Program
-> VersionRange
-> ProgramDb
-> IO (ConfiguredProgram, Version, ProgramDb)
requireProgramVersion
        Verbosity
verbosity
        Program
hpcProgram
        VersionRange
anyVersion
        (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
    let htmlDir_ :: String
htmlDir_ = String -> Way -> ShowS
htmlDir String
distPref Way
way String
testName'
    ConfiguredProgram
-> Version
-> Verbosity
-> String
-> [String]
-> String
-> [ModuleName]
-> IO ()
markup
      ConfiguredProgram
hpc
      Version
hpcVer
      Verbosity
verbosity
      (String -> Way -> ShowS
tixFilePath String
distPref Way
way String
testName')
      [String]
mixDirs
      String
htmlDir_
      (Library -> [ModuleName]
exposedModules Library
library)
    Verbosity -> String -> IO ()
notice Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
      String
"Test coverage report written to "
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
htmlDir_
        String -> ShowS
</> String
"hpc_index" String -> ShowS
<.> String
"html"
  where
    way :: Way
way = LocalBuildInfo -> Way
guessWay LocalBuildInfo
lbi
    testName' :: String
testName' = UnqualComponentName -> String
unUnqualComponentName (UnqualComponentName -> String) -> UnqualComponentName -> String
forall a b. (a -> b) -> a -> b
$ TestSuite -> UnqualComponentName
testName TestSuite
suite
    mixDirs :: [String]
mixDirs = ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Way -> ShowS
mixDir String
distPref Way
way) [String
testName', String
libraryName]

-- | Generate the HTML markup for all of a package's test suites.
markupPackage
  :: Verbosity
  -> LocalBuildInfo
  -> FilePath
  -- ^ \"dist/\" prefix
  -> PD.PackageDescription
  -> [TestSuite]
  -> IO ()
markupPackage :: Verbosity
-> LocalBuildInfo
-> String
-> PackageDescription
-> [TestSuite]
-> IO ()
markupPackage Verbosity
verbosity LocalBuildInfo
lbi String
distPref PackageDescription
pkg_descr [TestSuite]
suites = do
  let tixFiles :: [String]
tixFiles = ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Way -> ShowS
tixFilePath String
distPref Way
way) [String]
testNames
  [Bool]
tixFilesExist <- (String -> IO Bool) -> [String] -> 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]
tixFiles
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
tixFilesExist) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    -- behaviour of 'markup' depends on version, so we need *a* version
    -- but no particular one
    (ConfiguredProgram
hpc, Version
hpcVer, ProgramDb
_) <-
      Verbosity
-> Program
-> VersionRange
-> ProgramDb
-> IO (ConfiguredProgram, Version, ProgramDb)
requireProgramVersion
        Verbosity
verbosity
        Program
hpcProgram
        VersionRange
anyVersion
        (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
    let outFile :: String
outFile = String -> Way -> ShowS
tixFilePath String
distPref Way
way String
libraryName
        htmlDir' :: String
htmlDir' = String -> Way -> ShowS
htmlDir String
distPref Way
way String
libraryName
        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]
    Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ ShowS
takeDirectory String
outFile
    ConfiguredProgram
-> Verbosity -> [String] -> String -> [ModuleName] -> IO ()
union ConfiguredProgram
hpc Verbosity
verbosity [String]
tixFiles String
outFile [ModuleName]
excluded
    ConfiguredProgram
-> Version
-> Verbosity
-> String
-> [String]
-> String
-> [ModuleName]
-> IO ()
markup ConfiguredProgram
hpc Version
hpcVer Verbosity
verbosity String
outFile [String]
mixDirs String
htmlDir' [ModuleName]
included
    Verbosity -> String -> IO ()
notice Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
      String
"Package coverage report written to "
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
htmlDir'
        String -> ShowS
</> String
"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 :: [String]
mixDirs = ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Way -> ShowS
mixDir String
distPref Way
way) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String
libraryName String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
testNames
    included :: [ModuleName]
included = (Library -> [ModuleName]) -> [Library] -> [ModuleName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Library -> [ModuleName]
exposedModules) ([Library] -> [ModuleName]) -> [Library] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ PackageDescription -> [Library]
PD.allLibraries PackageDescription
pkg_descr
    libraryName :: String
libraryName = 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