Cabal/src/Distribution/Simple/Hpc.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE NamedFieldPuns #-}
   3 {-# LANGUAGE RankNTypes #-}
   4
   5 -----------------------------------------------------------------------------
   6
   7 -- |
   8 -- Module      :  Distribution.Simple.Hpc
   9 -- Copyright   :  Thomas Tuegel 2011
  10 -- License     :  BSD3
  11 --
  12 -- Maintainer  :  cabal-devel@haskell.org
  13 -- Portability :  portable
  14 --
  15 -- This module provides functions for locating various HPC-related paths and
  16 -- a function for adding the necessary options to a PackageDescription to
  17 -- build test suites with HPC enabled.
  18 module Distribution.Simple.Hpc
  19   ( Way (..)
  20   , guessWay
  21   , htmlDir
  22   , mixDir
  23   , tixDir
  24   , tixFilePath
  25   , HPCMarkupInfo (..)
  26   , markupPackage
  27   ) where
  28
  29 import Distribution.Compat.Prelude
  30 import Prelude ()
  31
  32 import Distribution.ModuleName (ModuleName, main)
  33 import Distribution.PackageDescription
  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   -- ^ Directory containing test suite's .mix files
  77 mixDir distPref way = hpcDir distPref way </> "mix"
  78
  79 tixDir
  80   :: FilePath
  81   -- ^ \"dist/\" prefix
  82   -> Way
  83   -> FilePath
  84   -- ^ Directory containing test suite's .tix files
  85 tixDir distPref way = hpcDir distPref way </> "tix"
  86
  87 -- | Path to the .tix file containing a test suite's sum statistics.
  88 tixFilePath
  89   :: FilePath
  90   -- ^ \"dist/\" prefix
  91   -> Way
  92   -> FilePath
  93   -- ^ Component name
  94   -> FilePath
  95   -- ^ Path to test suite's .tix file
  96 tixFilePath distPref way name = tixDir distPref way </> name <.> "tix"
  97
  98 htmlDir
  99   :: FilePath
 100   -- ^ \"dist/\" prefix
 101   -> Way
 102   -> FilePath
 103   -- ^ Path to test suite's HTML markup directory
 104 htmlDir distPref way = hpcDir distPref way </> "html"
 105
 106 -- | Attempt to guess the way the test suites in this package were compiled
 107 -- and linked with the library so the correct module interfaces are found.
 108 guessWay :: LocalBuildInfo -> Way
 109 guessWay lbi
 110   | withProfExe lbi = Prof
 111   | withDynExe lbi = Dyn
 112   | otherwise = Vanilla
 113
 114 -- | Haskell Program Coverage information required to produce a valid HPC
 115 -- report through the `hpc markup` call for the package libraries.
 116 data HPCMarkupInfo = HPCMarkupInfo
 117   { pathsToLibsArtifacts :: [FilePath]
 118   -- ^ The paths to the library components whose modules are included in the
 119   -- coverage report
 120   , libsModulesToInclude :: [ModuleName]
 121   -- ^ The modules to include in the coverage report
 122   }
 123
 124 -- | Generate the HTML markup for a package's test suites.
 125 markupPackage
 126   :: Verbosity
 127   -> HPCMarkupInfo
 128   -> LocalBuildInfo
 129   -> FilePath
 130   -- ^ Testsuite \"dist/\" prefix
 131   -> PD.PackageDescription
 132   -> [TestSuite]
 133   -> IO ()
 134 markupPackage verbosity HPCMarkupInfo{pathsToLibsArtifacts, libsModulesToInclude} lbi testDistPref pkg_descr suites = do
 135   let tixFiles = map (tixFilePath testDistPref way) testNames
 136   tixFilesExist <- traverse doesFileExist tixFiles
 137   when (and tixFilesExist) $ do
 138     -- behaviour of 'markup' depends on version, so we need *a* version
 139     -- but no particular one
 140     (hpc, hpcVer, _) <-
 141       requireProgramVersion
 142         verbosity
 143         hpcProgram
 144         anyVersion
 145         (withPrograms lbi)
 146     let htmlDir' = htmlDir testDistPref way
 147     -- The tix file used to generate the report is either the testsuite's
 148     -- tix file, when there is only one testsuite, or the sum of the tix
 149     -- files of all testsuites in the package, which gets put under pkgName
 150     -- for this component (a bit weird)
 151     -- TODO: cabal-install should pass to Cabal where to put the summed tix
 152     -- and report, and perhaps even the testsuites from other packages in
 153     -- the project which are currently not accounted for in the summed
 154     -- report.
 155     tixFile <- case suites of
 156       -- We call 'markupPackage' once for each testsuite to run individually,
 157       -- to get the coverage report of just the one testsuite
 158       [oneTest] -> do
 159         let testName' = unUnqualComponentName $ testName oneTest
 160         return $
 161           tixFilePath testDistPref way testName'
 162       -- And call 'markupPackage' once per `test` invocation with all the
 163       -- testsuites to run, which results in multiple tix files being considered
 164       _ -> do
 165         let excluded = concatMap testModules suites ++ [main]
 166             pkgName = prettyShow $ PD.package pkg_descr
 167             summedTixFile = tixFilePath testDistPref way pkgName
 168         createDirectoryIfMissing True $ takeDirectory summedTixFile
 169         union hpc verbosity tixFiles summedTixFile excluded
 170         return summedTixFile
 171
 172     markup hpc hpcVer verbosity tixFile mixDirs htmlDir' libsModulesToInclude
 173     notice verbosity $
 174       "Package coverage report written to "
 175         ++ htmlDir'
 176         </> "hpc_index.html"
 177   where
 178     way = guessWay lbi
 179     testNames = fmap (unUnqualComponentName . testName) suites
 180     mixDirs = map (`mixDir` way) pathsToLibsArtifacts