1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE RankNTypes #-}
3
4-----------------------------------------------------------------------------
5-- |
6-- Module      :  Distribution.Simple.Hpc
7-- Copyright   :  Thomas Tuegel 2011
8-- License     :  BSD3
9--
10-- Maintainer  :  cabal-devel@haskell.org
11-- Portability :  portable
12--
13-- This module provides functions for locating various HPC-related paths and
14-- a function for adding the necessary options to a PackageDescription to
15-- build test suites with HPC enabled.
16
17module Distribution.Simple.Hpc
18    ( Way(..), guessWay
19    , htmlDir
20    , mixDir
21    , tixDir
22    , tixFilePath
23    , markupPackage
24    , markupTest
25    ) where
26
27import Prelude ()
28import Distribution.Compat.Prelude
29
30import Distribution.Types.UnqualComponentName
31import Distribution.ModuleName ( main )
32import Distribution.PackageDescription
33    ( TestSuite(..)
34    , testModules
35    )
36import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) )
37import Distribution.Simple.Program
38    ( hpcProgram
39    , requireProgramVersion
40    )
41import Distribution.Simple.Program.Hpc ( markup, union )
42import Distribution.Simple.Utils ( notice )
43import Distribution.Version ( anyVersion )
44import Distribution.Verbosity ( Verbosity() )
45import System.Directory ( createDirectoryIfMissing, doesFileExist )
46import System.FilePath
47
48-- -------------------------------------------------------------------------
49-- Haskell Program Coverage
50
51data Way = Vanilla | Prof | Dyn
52  deriving (Bounded, Enum, Eq, Read, Show)
53
54hpcDir :: FilePath  -- ^ \"dist/\" prefix
55       -> Way
56       -> FilePath  -- ^ Directory containing component's HPC .mix files
57hpcDir distPref way = distPref </> "hpc" </> wayDir
58  where
59    wayDir = case way of
60      Vanilla -> "vanilla"
61      Prof -> "prof"
62      Dyn -> "dyn"
63
64mixDir :: FilePath  -- ^ \"dist/\" prefix
65       -> Way
66       -> FilePath  -- ^ Component name
67       -> FilePath  -- ^ Directory containing test suite's .mix files
68mixDir distPref way name = hpcDir distPref way </> "mix" </> name
69
70tixDir :: FilePath  -- ^ \"dist/\" prefix
71       -> Way
72       -> FilePath  -- ^ Component name
73       -> FilePath  -- ^ Directory containing test suite's .tix files
74tixDir distPref way name = hpcDir distPref way </> "tix" </> name
75
76-- | Path to the .tix file containing a test suite's sum statistics.
77tixFilePath :: FilePath     -- ^ \"dist/\" prefix
78            -> Way
79            -> FilePath     -- ^ Component name
80            -> FilePath     -- ^ Path to test suite's .tix file
81tixFilePath distPref way name = tixDir distPref way name </> name <.> "tix"
82
83htmlDir :: FilePath     -- ^ \"dist/\" prefix
84        -> Way
85        -> FilePath     -- ^ Component name
86        -> FilePath     -- ^ Path to test suite's HTML markup directory
87htmlDir distPref way name = hpcDir distPref way </> "html" </> name
88
89-- | Attempt to guess the way the test suites in this package were compiled
90-- and linked with the library so the correct module interfaces are found.
91guessWay :: LocalBuildInfo -> Way
92guessWay lbi
93  | withProfExe lbi = Prof
94  | withDynExe lbi = Dyn
95  | otherwise = Vanilla
96
97-- | Generate the HTML markup for a test suite.
98markupTest :: Verbosity
99           -> LocalBuildInfo
100           -> FilePath     -- ^ \"dist/\" prefix
101           -> String       -- ^ Library name
102           -> TestSuite
103           -> IO ()
104markupTest verbosity lbi distPref libName suite = do
105    tixFileExists <- doesFileExist $ tixFilePath distPref way $ testName'
106    when tixFileExists $ do
107        -- behaviour of 'markup' depends on version, so we need *a* version
108        -- but no particular one
109        (hpc, hpcVer, _) <- requireProgramVersion verbosity
110            hpcProgram anyVersion (withPrograms lbi)
111        let htmlDir_ = htmlDir distPref way testName'
112        markup hpc hpcVer verbosity
113            (tixFilePath distPref way testName') mixDirs
114            htmlDir_
115            (testModules suite ++ [ main ])
116        notice verbosity $ "Test coverage report written to "
117                            ++ htmlDir_ </> "hpc_index" <.> "html"
118  where
119    way = guessWay lbi
120    testName' = unUnqualComponentName $ testName suite
121    mixDirs = map (mixDir distPref way) [ testName', libName ]
122
123-- | Generate the HTML markup for all of a package's test suites.
124markupPackage :: Verbosity
125              -> LocalBuildInfo
126              -> FilePath       -- ^ \"dist/\" prefix
127              -> String         -- ^ Library name
128              -> [TestSuite]
129              -> IO ()
130markupPackage verbosity lbi distPref libName suites = do
131    let tixFiles = map (tixFilePath distPref way) testNames
132    tixFilesExist <- traverse doesFileExist tixFiles
133    when (and tixFilesExist) $ do
134        -- behaviour of 'markup' depends on version, so we need *a* version
135        -- but no particular one
136        (hpc, hpcVer, _) <- requireProgramVersion verbosity
137            hpcProgram anyVersion (withPrograms lbi)
138        let outFile = tixFilePath distPref way libName
139            htmlDir' = htmlDir distPref way libName
140            excluded = concatMap testModules suites ++ [ main ]
141        createDirectoryIfMissing True $ takeDirectory outFile
142        union hpc verbosity tixFiles outFile excluded
143        markup hpc hpcVer verbosity outFile mixDirs htmlDir' excluded
144        notice verbosity $ "Package coverage report written to "
145                           ++ htmlDir' </> "hpc_index.html"
146  where
147    way = guessWay lbi
148    testNames = fmap (unUnqualComponentName . testName) suites
149    mixDirs = map (mixDir distPref way) $ libName : testNames
150