{-# 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 Prelude ()
import Distribution.Compat.Prelude

import Distribution.Types.UnqualComponentName
import Distribution.ModuleName ( main )
import Distribution.PackageDescription
    ( TestSuite(..)
    , testModules
    )
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

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

data Way = Vanilla | Prof | Dyn
  deriving (Way
Way -> Way -> Bounded Way
forall a. a -> a -> Bounded a
maxBound :: Way
$cmaxBound :: Way
minBound :: Way
$cminBound :: 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
enumFromThenTo :: Way -> Way -> Way -> [Way]
$cenumFromThenTo :: Way -> Way -> Way -> [Way]
enumFromTo :: Way -> Way -> [Way]
$cenumFromTo :: Way -> Way -> [Way]
enumFromThen :: Way -> Way -> [Way]
$cenumFromThen :: Way -> Way -> [Way]
enumFrom :: Way -> [Way]
$cenumFrom :: Way -> [Way]
fromEnum :: Way -> Int
$cfromEnum :: Way -> Int
toEnum :: Int -> Way
$ctoEnum :: Int -> Way
pred :: Way -> Way
$cpred :: Way -> Way
succ :: Way -> Way
$csucc :: Way -> Way
External instance of the constraint type Enum Int
External instance of the constraint type Show Int
External instance of the constraint type Show Int
External instance of the constraint type Ord Int
External instance of the constraint type Ord Int
External instance of the constraint type Num Int
External instance of the constraint type Eq Int
Enum, Way -> Way -> Bool
(Way -> Way -> Bool) -> (Way -> Way -> Bool) -> Eq Way
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Way -> Way -> Bool
$c/= :: Way -> Way -> Bool
== :: Way -> Way -> Bool
$c== :: 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
readListPrec :: ReadPrec [Way]
$creadListPrec :: ReadPrec [Way]
readPrec :: ReadPrec Way
$creadPrec :: ReadPrec Way
readList :: ReadS [Way]
$creadList :: ReadS [Way]
readsPrec :: Int -> ReadS Way
$creadsPrec :: Int -> ReadS Way
External instance of the constraint type Monad ReadPrec
External instance of the constraint type Monad ReadPrec
Instance of class: Read of the constraint type Read 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
showList :: [Way] -> ShowS
$cshowList :: [Way] -> ShowS
show :: Way -> String
$cshow :: Way -> String
showsPrec :: Int -> Way -> ShowS
$cshowsPrec :: Int -> 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
distPref Way
way String -> ShowS
</> String
"mix" String -> ShowS
</> String
name

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
           -> IO ()
markupTest :: Verbosity
-> LocalBuildInfo -> String -> String -> TestSuite -> IO ()
markupTest Verbosity
verbosity LocalBuildInfo
lbi String
distPref String
libName TestSuite
suite = 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 ()
External instance of the constraint type Applicative IO
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_
            (TestSuite -> [ModuleName]
testModules TestSuite
suite [ModuleName] -> [ModuleName] -> [ModuleName]
forall a. [a] -> [a] -> [a]
++ [ ModuleName
main ])
        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
libName ]

-- | Generate the HTML markup for all of a package's test suites.
markupPackage :: Verbosity
              -> LocalBuildInfo
              -> FilePath       -- ^ \"dist/\" prefix
              -> String         -- ^ Library name
              -> [TestSuite]
              -> IO ()
markupPackage :: Verbosity
-> LocalBuildInfo -> String -> String -> [TestSuite] -> IO ()
markupPackage Verbosity
verbosity LocalBuildInfo
lbi String
distPref String
libName [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)
External instance of the constraint type Applicative IO
External instance of the constraint type Traversable []
traverse String -> IO Bool
doesFileExist [String]
tixFiles
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
External instance of the constraint type Applicative IO
when ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
External instance of the constraint type Foldable []
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
libName
            htmlDir' :: String
htmlDir' = String -> Way -> ShowS
htmlDir String
distPref Way
way String
libName
            excluded :: [ModuleName]
excluded = (TestSuite -> [ModuleName]) -> [TestSuite] -> [ModuleName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
External instance of the constraint type Foldable []
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]
excluded
        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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
External instance of the constraint type Functor []
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
libName String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
testNames