Hpc.hs

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

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

data Way = Vanilla | Prof | Dyn
  deriving (Bounded, Enum, Eq, Read, Show)

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

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

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

htmlDir :: FilePath     -- ^ \"dist/\" prefix
        -> Way
        -> FilePath     -- ^ Component name
        -> FilePath     -- ^ Path to test suite's HTML markup directory
htmlDir distPref way name = hpcDir distPref way </> "html" </> 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 lbi
  | withProfExe lbi = Prof
  | withDynExe lbi = Dyn
  | otherwise = Vanilla

-- | Generate the HTML markup for a test suite.
markupTest :: Verbosity
           -> LocalBuildInfo
           -> FilePath     -- ^ \"dist/\" prefix
           -> String       -- ^ Library name
           -> TestSuite
           -> Library
           -> IO ()
markupTest verbosity lbi distPref libraryName suite library = do
    tixFileExists <- doesFileExist $ tixFilePath distPref way $ testName'
    when tixFileExists $ 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_ = 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 ]

-- | Generate the HTML markup for all of a package's test suites.
markupPackage :: Verbosity
              -> LocalBuildInfo
              -> FilePath       -- ^ \"dist/\" prefix
              -> 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
        -- behaviour of 'markup' depends on version, so we need *a* version
        -- but no particular one
        (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