Cabal/src/Distribution/Simple/Hpc.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE RankNTypes #-}
   3
   4 -----------------------------------------------------------------------------
   5
   6 -- |
   7 -- Module      :  Distribution.Simple.Hpc
   8 -- Copyright   :  Thomas Tuegel 2011
   9 -- License     :  BSD3
  10 --
  11 -- Maintainer  :  cabal-devel@haskell.org
  12 -- Portability :  portable
  13 --
  14 -- This module provides functions for locating various HPC-related paths and
  15 -- a function for adding the necessary options to a PackageDescription to
  16 -- build test suites with HPC enabled.
  17 module Distribution.Simple.Hpc
  18   ( Way (..)
  19   , guessWay
  20   , htmlDir
  21   , mixDir
  22   , tixDir
  23   , tixFilePath
  24   , markupPackage
  25   , markupTest
  26   ) where
  27
  28 import Distribution.Compat.Prelude
  29 import Prelude ()
  30
  31 import Distribution.ModuleName (main)
  32 import Distribution.PackageDescription
  33   ( Library (..)
  34   , TestSuite (..)
  35   , testModules
  36   )
  37 import qualified Distribution.PackageDescription as PD
  38 import Distribution.Pretty
  39 import Distribution.Simple.LocalBuildInfo (LocalBuildInfo (..))
  40 import Distribution.Simple.Program
  41   ( hpcProgram
  42   , requireProgramVersion
  43   )
  44 import Distribution.Simple.Program.Hpc (markup, union)
  45 import Distribution.Simple.Utils (notice)
  46 import Distribution.Types.UnqualComponentName
  47 import Distribution.Verbosity (Verbosity ())
  48 import Distribution.Version (anyVersion)
  49 import System.Directory (createDirectoryIfMissing, doesFileExist)
  50 import System.FilePath
  51
  52 -- -------------------------------------------------------------------------
  53 -- Haskell Program Coverage
  54
  55 data Way = Vanilla | Prof | Dyn
  56   deriving (Bounded, Enum, Eq, Read, Show)
  57
  58 hpcDir
  59   :: FilePath
  60   -- ^ \"dist/\" prefix
  61   -> Way
  62   -> FilePath
  63   -- ^ Directory containing component's HPC .mix files
  64 hpcDir distPref way = distPref </> "hpc" </> wayDir
  65   where
  66     wayDir = case way of
  67       Vanilla -> "vanilla"
  68       Prof -> "prof"
  69       Dyn -> "dyn"
  70
  71 mixDir
  72   :: FilePath
  73   -- ^ \"dist/\" prefix
  74   -> Way
  75   -> FilePath
  76   -- ^ Component name
  77   -> FilePath
  78   -- ^ Directory containing test suite's .mix files
  79 mixDir distPref way name = hpcDir distPrefBuild way </> "mix" </> name
  80   where
  81     -- This is a hack for HPC over test suites, needed to match the directory
  82     -- where HPC saves and reads .mix files when the main library of the same
  83     -- package is being processed, perhaps in a previous cabal run (#5213).
  84     -- E.g., @distPref@ may be
  85     -- @./dist-newstyle/build/x86_64-linux/ghc-9.0.1/cabal-gh5213-0.1/t/tests@
  86     -- but the path where library mix files reside has two less components
  87     -- at the end (@t/tests@) and this reduced path needs to be passed to
  88     -- both @hpc@ and @ghc@. For non-default optimization levels, the path
  89     -- suffix is one element longer and the extra path element needs
  90     -- to be preserved.
  91     distPrefElements = splitDirectories distPref
  92     distPrefBuild = case drop (length distPrefElements - 3) distPrefElements of
  93       ["t", _, "noopt"] ->
  94         joinPath $
  95           take (length distPrefElements - 3) distPrefElements
  96             ++ ["noopt"]
  97       ["t", _, "opt"] ->
  98         joinPath $
  99           take (length distPrefElements - 3) distPrefElements
 100             ++ ["opt"]
 101       [_, "t", _] ->
 102         joinPath $ take (length distPrefElements - 2) distPrefElements
 103       _ -> distPref
 104
 105 tixDir
 106   :: FilePath
 107   -- ^ \"dist/\" prefix
 108   -> Way
 109   -> FilePath
 110   -- ^ Component name
 111   -> FilePath
 112   -- ^ Directory containing test suite's .tix files
 113 tixDir distPref way name = hpcDir distPref way </> "tix" </> name
 114
 115 -- | Path to the .tix file containing a test suite's sum statistics.
 116 tixFilePath
 117   :: FilePath
 118   -- ^ \"dist/\" prefix
 119   -> Way
 120   -> FilePath
 121   -- ^ Component name
 122   -> FilePath
 123   -- ^ Path to test suite's .tix file
 124 tixFilePath distPref way name = tixDir distPref way name </> name <.> "tix"
 125
 126 htmlDir
 127   :: FilePath
 128   -- ^ \"dist/\" prefix
 129   -> Way
 130   -> FilePath
 131   -- ^ Component name
 132   -> FilePath
 133   -- ^ Path to test suite's HTML markup directory
 134 htmlDir distPref way name = hpcDir distPref way </> "html" </> name
 135
 136 -- | Attempt to guess the way the test suites in this package were compiled
 137 -- and linked with the library so the correct module interfaces are found.
 138 guessWay :: LocalBuildInfo -> Way
 139 guessWay lbi
 140   | withProfExe lbi = Prof
 141   | withDynExe lbi = Dyn
 142   | otherwise = Vanilla
 143
 144 -- | Generate the HTML markup for a test suite.
 145 markupTest
 146   :: Verbosity
 147   -> LocalBuildInfo
 148   -> FilePath
 149   -- ^ \"dist/\" prefix
 150   -> String
 151   -- ^ Library name
 152   -> TestSuite
 153   -> Library
 154   -> IO ()
 155 markupTest verbosity lbi distPref libraryName suite library = do
 156   tixFileExists <- doesFileExist $ tixFilePath distPref way $ testName'
 157   when tixFileExists $ do
 158     -- behaviour of 'markup' depends on version, so we need *a* version
 159     -- but no particular one
 160     (hpc, hpcVer, _) <-
 161       requireProgramVersion
 162         verbosity
 163         hpcProgram
 164         anyVersion
 165         (withPrograms lbi)
 166     let htmlDir_ = htmlDir distPref way testName'
 167     markup
 168       hpc
 169       hpcVer
 170       verbosity
 171       (tixFilePath distPref way testName')
 172       mixDirs
 173       htmlDir_
 174       (exposedModules library)
 175     notice verbosity $
 176       "Test coverage report written to "
 177         ++ htmlDir_
 178         </> "hpc_index" <.> "html"
 179   where
 180     way = guessWay lbi
 181     testName' = unUnqualComponentName $ testName suite
 182     mixDirs = map (mixDir distPref way) [testName', libraryName]
 183
 184 -- | Generate the HTML markup for all of a package's test suites.
 185 markupPackage
 186   :: Verbosity
 187   -> LocalBuildInfo
 188   -> FilePath
 189   -- ^ \"dist/\" prefix
 190   -> PD.PackageDescription
 191   -> [TestSuite]
 192   -> IO ()
 193 markupPackage verbosity lbi distPref pkg_descr suites = do
 194   let tixFiles = map (tixFilePath distPref way) testNames
 195   tixFilesExist <- traverse doesFileExist tixFiles
 196   when (and tixFilesExist) $ do
 197     -- behaviour of 'markup' depends on version, so we need *a* version
 198     -- but no particular one
 199     (hpc, hpcVer, _) <-
 200       requireProgramVersion
 201         verbosity
 202         hpcProgram
 203         anyVersion
 204         (withPrograms lbi)
 205     let outFile = tixFilePath distPref way libraryName
 206         htmlDir' = htmlDir distPref way libraryName
 207         excluded = concatMap testModules suites ++ [main]
 208     createDirectoryIfMissing True $ takeDirectory outFile
 209     union hpc verbosity tixFiles outFile excluded
 210     markup hpc hpcVer verbosity outFile mixDirs htmlDir' included
 211     notice verbosity $
 212       "Package coverage report written to "
 213         ++ htmlDir'
 214         </> "hpc_index.html"
 215   where
 216     way = guessWay lbi
 217     testNames = fmap (unUnqualComponentName . testName) suites
 218     mixDirs = map (mixDir distPref way) $ libraryName : testNames
 219     included = concatMap (exposedModules) $ PD.allLibraries pkg_descr
 220     libraryName = prettyShow $ PD.package pkg_descr