Skip to content

Commit

Permalink
HPC artifacts are written and read from pkg-db
Browse files Browse the repository at this point in the history
This commit re-designs the mechanism by which we make the .mix files of
libraries available to produce the Haskell Program Coverage report after
running testsuites.

The idea, for the Cabal library, is:

* Cabal builds libraries with -fhpc, and store the hpc artifacts in
  build </> `extraCompilationArtifacts`
* At Cabal install time, `extraCompilationArtifacts` is copied into the
  package database
* At Cabal configure time, we both
    - receive as --coverage-for flags unit-ids of library components
      from the same package (ultimately, when haskell#9493 is resolved, we will
      receive unit ids of libraries in other packages in the same
      project too),
    - and, when configuring a whole package instead of just a testsuite
      component, we determine the unit-ids of libraries in the package
  these unit-ids are written into `configCoverageFor` in `ConfigFlags`
* At Cabal test time, for each library to cover (stored in
  `configCoverageFor`), we look in the package database for the hpc
  dirs, which we eventually pass along to the `hpc markup` call as
  `--hpcdir` flags

As for cabal-install:

* After a plan has been elaborated, we select the packages which can be
  covered and pass them to Cabal's ./Setup configure as
  --coverage-for=<unit-id> flags.
    - Notably, valid libraries are non-indefinite and
      non-instantiations, since HPC does not support backpack.
    - Furthermore, we only include libraries in the same package as the
      component being configured, despite possibly there being
      more library components in other packages of the same project.
      When haskell#9493 is resolved, we could lift this restriction and pass
      all libraries local to the package as --coverage-for. See
      `determineCoverageFor` and `shouldCoverPkg` in Distribution.Client.ProjectPlanning.

Detail:
    We no longer pass the path to the testsuite's mix dirs to `hpc
    markup` because we only ever include modules in libraries, which
    means they were previously unused.

Fixes haskell#6440 (internal libs coverage), haskell#6397 (backpack breaks coverage),
doesn't yet fix haskell#8609 (multi-package coverage report) which is tracked
in haskell#9493, and fixes in a new way the previously fixed haskell#4798, haskell#5213.
  • Loading branch information
alt-romes committed Dec 11, 2023
1 parent 116de5e commit f17680f
Show file tree
Hide file tree
Showing 41 changed files with 423 additions and 156 deletions.
4 changes: 2 additions & 2 deletions Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs
Original file line number Diff line number Diff line change
Expand Up @@ -41,7 +41,7 @@ md5CheckGenericPackageDescription proxy = md5Check proxy
md5CheckLocalBuildInfo :: Proxy LocalBuildInfo -> Assertion
md5CheckLocalBuildInfo proxy = md5Check proxy
#if MIN_VERSION_base(4,19,0)
0x205fbe2649bc5e488bce50c07a71cadb
0x512e880894570552f08aa82547568dbc
#else
0x26e91a71ebd19d4d6ce37f798ede249a
0x968807984ad42d41a9e9ab696a9fec58
#endif
42 changes: 40 additions & 2 deletions Cabal/src/Distribution/Simple/Configure.hs
Original file line number Diff line number Diff line change
@@ -1,5 +1,7 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
Expand Down Expand Up @@ -44,6 +46,7 @@ module Distribution.Simple.Configure
, localBuildInfoFile
, getInstalledPackages
, getInstalledPackagesMonitorFiles
, getInstalledPackagesById
, getPackageDBContents
, configCompilerEx
, configCompilerAuxEx
Expand All @@ -56,6 +59,7 @@ module Distribution.Simple.Configure
, platformDefines
) where

import Control.Monad
import Distribution.Compat.Prelude
import Prelude ()

Expand All @@ -78,7 +82,7 @@ import Distribution.Simple.BuildTarget
import Distribution.Simple.BuildToolDepends
import Distribution.Simple.Compiler
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
import Distribution.Simple.PackageIndex (InstalledPackageIndex, lookupUnitId)
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.PreProcess
import Distribution.Simple.Program
Expand Down Expand Up @@ -162,6 +166,7 @@ import qualified Data.Maybe as M
import qualified Data.Set as Set
import qualified Distribution.Compat.NonEmptySet as NES
import Distribution.Simple.Errors
import Distribution.Simple.Flag (mergeListFlag)
import Distribution.Types.AnnotatedId

type UseExternalInternalDeps = Bool
Expand Down Expand Up @@ -877,10 +882,21 @@ configure (pkg_descr0, pbi) cfg = do
Map.empty
buildComponents

-- For whole-package configure, we have to determine the additional
-- configCoverageFor of the main lib and sub libs here.
let extraCoverageFor :: [UnitId] = case enabled of
-- Whole package configure, add package libs
ComponentRequestedSpec{} -> mapMaybe (\case LibComponentLocalBuildInfo{componentUnitId} -> Just componentUnitId; _ -> Nothing) buildComponents
-- Component configure, no need to do anything
OneComponentRequestedSpec{} -> []

-- TODO: Should we also enforce something here on that --coverage-for cannot
-- include indefinite components or instantiations?

let lbi =
(setCoverageLBI . setProfLBI)
LocalBuildInfo
{ configFlags = cfg
{ configFlags = cfg{configCoverageFor = mergeListFlag (configCoverageFor cfg) (toFlag extraCoverageFor)}
, flagAssignment = flags
, componentEnabledSpec = enabled
, extraConfigArgs = [] -- Currently configure does not
Expand Down Expand Up @@ -1747,6 +1763,28 @@ getInstalledPackagesMonitorFiles verbosity comp packageDBs progdb platform =
++ prettyShow other
return []

-- | Looks up the 'InstalledPackageInfo' of the given 'UnitId's from the
-- 'PackageDBStack' in the 'LocalBuildInfo'.
getInstalledPackagesById
:: (Exception (VerboseException exception), Show exception, Typeable exception)
=> Verbosity
-> LocalBuildInfo
-> (UnitId -> exception)
-- ^ Construct an exception that is thrown if a
-- unit-id is not found in the installed packages,
-- from the unit-id that is missing.
-> [UnitId]
-- ^ The unit ids to lookup in the installed packages
-> IO [InstalledPackageInfo]
getInstalledPackagesById verbosity LocalBuildInfo{compiler, withPackageDB, withPrograms} mkException unitids = do
ipindex <- getInstalledPackages verbosity compiler withPackageDB withPrograms
mapM
( \uid -> case lookupUnitId ipindex uid of
Nothing -> dieWithException verbosity (mkException uid)
Just ipkg -> return ipkg
)
unitids

-- | The user interface specifies the package dbs to use with a combination of
-- @--global@, @--user@ and @--package-db=global|user|clear|$file@.
-- This function combines the global/user flag and interprets the package-db
Expand Down
6 changes: 6 additions & 0 deletions Cabal/src/Distribution/Simple/Errors.hs
Original file line number Diff line number Diff line change
Expand Up @@ -170,6 +170,7 @@ data CabalException
| NoProgramFound String VersionRange
| BadVersionDb String Version VersionRange FilePath
| UnknownVersionDb String VersionRange FilePath
| MissingCoveredInstalledLibrary UnitId
deriving (Show, Typeable)

exceptionCode :: CabalException -> Int
Expand Down Expand Up @@ -301,6 +302,7 @@ exceptionCode e = case e of
NoProgramFound{} -> 7620
BadVersionDb{} -> 8038
UnknownVersionDb{} -> 1008
MissingCoveredInstalledLibrary{} -> 9341

versionRequirement :: VersionRange -> String
versionRequirement range
Expand Down Expand Up @@ -791,3 +793,7 @@ exceptionMessage e = case e of
++ " is required but the version of "
++ locationPath
++ " could not be determined."
MissingCoveredInstalledLibrary unitId ->
"Failed to find the installed unit '"
++ prettyShow unitId
++ "' in package database stack."
6 changes: 2 additions & 4 deletions Cabal/src/Distribution/Simple/GHC/BuildGeneric.hs
Original file line number Diff line number Diff line change
Expand Up @@ -19,7 +19,6 @@ import Distribution.PackageDescription.Utils (cabalBug)
import Distribution.Pretty
import Distribution.Simple.BuildPaths
import Distribution.Simple.Compiler
import Distribution.Simple.Flag (Flag (..), fromFlag, toFlag)
import Distribution.Simple.GHC.Build
( checkNeedsRecompilation
, componentGhcOptions
Expand All @@ -39,7 +38,7 @@ import Distribution.Simple.LocalBuildInfo
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.Program
import Distribution.Simple.Program.GHC
import Distribution.Simple.Setup.Config
import Distribution.Simple.Setup.Common
import Distribution.Simple.Setup.Repl
import Distribution.Simple.Utils
import Distribution.System
Expand Down Expand Up @@ -399,10 +398,9 @@ gbuild verbosity numJobs pkg_descr lbi bm clbi = do
-- Determine if program coverage should be enabled and if so, what
-- '-hpcdir' should be.
let isCoverageEnabled = exeCoverage lbi
distPref = fromFlag $ configDistPref $ configFlags lbi
hpcdir way
| gbuildIsRepl bm = mempty -- HPC is not supported in ghci
| isCoverageEnabled = toFlag $ Hpc.mixDir distPref way
| isCoverageEnabled = toFlag $ Hpc.mixDir (tmpDir </> extraCompilationArtifacts) way
| otherwise = mempty

rpaths <- getRPaths lbi clbi
Expand Down
6 changes: 2 additions & 4 deletions Cabal/src/Distribution/Simple/GHC/BuildOrRepl.hs
Original file line number Diff line number Diff line change
Expand Up @@ -9,7 +9,6 @@ import Distribution.Package
import Distribution.PackageDescription as PD
import Distribution.Simple.BuildPaths
import Distribution.Simple.Compiler
import Distribution.Simple.Flag (Flag (..), fromFlag, toFlag)
import Distribution.Simple.GHC.Build
( checkNeedsRecompilation
, componentGhcOptions
Expand All @@ -27,7 +26,7 @@ import Distribution.Simple.Program
import qualified Distribution.Simple.Program.Ar as Ar
import Distribution.Simple.Program.GHC
import qualified Distribution.Simple.Program.Ld as Ld
import Distribution.Simple.Setup.Config
import Distribution.Simple.Setup.Common
import Distribution.Simple.Setup.Repl
import Distribution.Simple.Utils
import Distribution.System
Expand Down Expand Up @@ -96,10 +95,9 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do
-- Determine if program coverage should be enabled and if so, what
-- '-hpcdir' should be.
let isCoverageEnabled = libCoverage lbi
distPref = fromFlag $ configDistPref $ configFlags lbi
hpcdir way
| forRepl = mempty -- HPC is not supported in ghci
| isCoverageEnabled = toFlag $ Hpc.mixDir distPref way
| isCoverageEnabled = toFlag $ Hpc.mixDir (libTargetDir </> extraCompilationArtifacts) way
| otherwise = mempty

createDirectoryIfMissingVerbose verbosity True libTargetDir
Expand Down
8 changes: 3 additions & 5 deletions Cabal/src/Distribution/Simple/GHCJS.hs
Original file line number Diff line number Diff line change
Expand Up @@ -72,7 +72,7 @@ import Distribution.Simple.Program
import Distribution.Simple.Program.GHC
import qualified Distribution.Simple.Program.HcPkg as HcPkg
import qualified Distribution.Simple.Program.Strip as Strip
import Distribution.Simple.Setup.Config
import Distribution.Simple.Setup.Common
import Distribution.Simple.Utils
import Distribution.System
import Distribution.Types.ComponentLocalBuildInfo
Expand Down Expand Up @@ -515,10 +515,9 @@ buildOrReplLib mReplFlags verbosity numJobs _pkg_descr lbi lib clbi = do
-- Determine if program coverage should be enabled and if so, what
-- '-hpcdir' should be.
let isCoverageEnabled = libCoverage lbi
distPref = fromFlag $ configDistPref $ configFlags lbi
hpcdir way
| forRepl = mempty -- HPC is not supported in ghci
| isCoverageEnabled = toFlag $ Hpc.mixDir distPref way
| isCoverageEnabled = toFlag $ Hpc.mixDir (libTargetDir </> extraCompilationArtifacts) way
| otherwise = mempty

createDirectoryIfMissingVerbose verbosity True libTargetDir
Expand Down Expand Up @@ -1235,10 +1234,9 @@ gbuild verbosity numJobs pkg_descr lbi bm clbi = do
-- Determine if program coverage should be enabled and if so, what
-- '-hpcdir' should be.
let isCoverageEnabled = exeCoverage lbi
distPref = fromFlag $ configDistPref $ configFlags lbi
hpcdir way
| gbuildIsRepl bm = mempty -- HPC is not supported in ghci
| isCoverageEnabled = toFlag $ Hpc.mixDir distPref way
| isCoverageEnabled = toFlag $ Hpc.mixDir (tmpDir </> extraCompilationArtifacts) way
| otherwise = mempty

rpaths <- getRPaths lbi clbi
Expand Down
24 changes: 16 additions & 8 deletions Cabal/src/Distribution/Simple/Hpc.hs
Original file line number Diff line number Diff line change
Expand Up @@ -22,27 +22,26 @@ module Distribution.Simple.Hpc
, mixDir
, tixDir
, tixFilePath
, HPCMarkupInfo (..)
, markupPackage
) where

import Distribution.Compat.Prelude
import Prelude ()

import Distribution.ModuleName (main)
import Distribution.ModuleName (ModuleName, main)
import Distribution.PackageDescription
( TestSuite (..)
, testModules
)
import qualified Distribution.PackageDescription as PD
import Distribution.Pretty
import Distribution.Simple.Flag (fromFlagOrDefault)
import Distribution.Simple.LocalBuildInfo (LocalBuildInfo (..))
import Distribution.Simple.Program
( hpcProgram
, requireProgramVersion
)
import Distribution.Simple.Program.Hpc (markup, union)
import Distribution.Simple.Setup (TestFlags (..))
import Distribution.Simple.Utils (notice)
import Distribution.Types.UnqualComponentName
import Distribution.Verbosity (Verbosity ())
Expand Down Expand Up @@ -112,17 +111,27 @@ guessWay lbi
| withDynExe lbi = Dyn
| otherwise = Vanilla

-- | Haskell Program Coverage information required to produce a valid HPC
-- report through the `hpc markup` call for the package libraries.
data HPCMarkupInfo = HPCMarkupInfo
{ pathsToLibsArtifacts :: [FilePath]
-- ^ The paths to the library components whose modules are included in the
-- coverage report
, libsModulesToInclude :: [ModuleName]
-- ^ The modules to include in the coverage report
}

-- | Generate the HTML markup for a package's test suites.
markupPackage
:: Verbosity
-> TestFlags
-> HPCMarkupInfo
-> LocalBuildInfo
-> FilePath
-- ^ Testsuite \"dist/\" prefix
-> PD.PackageDescription
-> [TestSuite]
-> IO ()
markupPackage verbosity TestFlags{testCoverageDistPrefs, testCoverageLibsModules} lbi testDistPref pkg_descr suites = do
markupPackage verbosity HPCMarkupInfo{pathsToLibsArtifacts, libsModulesToInclude} lbi testDistPref pkg_descr suites = do
let tixFiles = map (tixFilePath testDistPref way) testNames
tixFilesExist <- traverse doesFileExist tixFiles
when (and tixFilesExist) $ do
Expand Down Expand Up @@ -160,13 +169,12 @@ markupPackage verbosity TestFlags{testCoverageDistPrefs, testCoverageLibsModules
union hpc verbosity tixFiles summedTixFile excluded
return summedTixFile

markup hpc hpcVer verbosity tixFile mixDirs htmlDir' included
markup hpc hpcVer verbosity tixFile mixDirs htmlDir' libsModulesToInclude
notice verbosity $
"Package coverage report written to "
++ htmlDir'
</> "hpc_index.html"
where
way = guessWay lbi
testNames = fmap (unUnqualComponentName . testName) suites
mixDirs = map (`mixDir` way) (fromFlagOrDefault [] testCoverageDistPrefs)
included = fromFlagOrDefault [] testCoverageLibsModules
mixDirs = map (`mixDir` way) pathsToLibsArtifacts
23 changes: 23 additions & 0 deletions Cabal/src/Distribution/Simple/Setup/Config.hs
Original file line number Diff line number Diff line change
Expand Up @@ -54,6 +54,7 @@ import Distribution.Types.DumpBuildInfo
import Distribution.Types.GivenComponent
import Distribution.Types.Module
import Distribution.Types.PackageVersionConstraint
import Distribution.Types.UnitId
import Distribution.Utils.NubList
import Distribution.Verbosity
import qualified Text.PrettyPrint as Disp
Expand Down Expand Up @@ -220,6 +221,11 @@ data ConfigFlags = ConfigFlags
-- ^ Allow depending on private sublibraries. This is used by external
-- tools (like cabal-install) so they can add multiple-public-libraries
-- compatibility to older ghcs by checking visibility externally.
, configCoverageFor :: Flag [UnitId]
-- ^ The list of libraries to be included in the hpc coverage report for
-- testsuites run with @--enable-coverage@. Notably, this list must exclude
-- indefinite libraries and instantiations because HPC does not support
-- backpack (Nov. 2023).
}
deriving (Generic, Read, Show, Typeable)

Expand Down Expand Up @@ -288,6 +294,7 @@ instance Eq ConfigFlags where
&& equal configDebugInfo
&& equal configDumpBuildInfo
&& equal configUseResponseFiles
&& equal configCoverageFor
where
equal f = on (==) f a b

Expand Down Expand Up @@ -828,6 +835,22 @@ configureOptions showOrParseArgs =
configAllowDependingOnPrivateLibs
(\v flags -> flags{configAllowDependingOnPrivateLibs = v})
trueArg
, option
""
["coverage-for"]
"A list of unit-ids of libraries to include in the Haskell Program Coverage report."
configCoverageFor
( \v flags ->
flags
{ configCoverageFor =
mergeListFlag (configCoverageFor flags) v
}
)
( reqArg'
"UNITID"
(Flag . (: []) . fromString)
(fmap prettyShow . fromFlagOrDefault [])
)
]
where
liftInstallDirs =
Expand Down
Loading

0 comments on commit f17680f

Please sign in to comment.