Merge pull request #9464 from alt-romes/wip/romes/4798

Allow per-component builds with coverage enabled

Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs

@@ -41,7 +41,7 @@ md5CheckGenericPackageDescription proxy = md5Check proxy
 md5CheckLocalBuildInfo :: Proxy LocalBuildInfo -> Assertion
 md5CheckLocalBuildInfo proxy = md5Check proxy
 #if MIN_VERSION_base(4,19,0)
-    0x23942cff98237dc167ef90d64d7ef893
+    0x023b3cd1665b2acdedf72d231c96336b
 #else
-    0xa4e9f8a7e1583906880d6ec2d1bbb14b
+    0xc6c0cc122cc60ce7943764cbaaacdc2d
 #endif

Cabal/src/Distribution/Simple/Configure.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE RecordWildCards #-}
@@ -44,6 +46,7 @@ module Distribution.Simple.Configure
   , localBuildInfoFile
   , getInstalledPackages
   , getInstalledPackagesMonitorFiles
+  , getInstalledPackagesById
   , getPackageDBContents
   , configCompilerEx
   , configCompilerAuxEx
@@ -56,6 +59,7 @@ module Distribution.Simple.Configure
   , platformDefines
   ) where
 
+import Control.Monad
 import Distribution.Compat.Prelude
 import Prelude ()
 
@@ -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
@@ -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
@@ -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
@@ -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

Cabal/src/Distribution/Simple/Errors.hs

@@ -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
@@ -301,6 +302,7 @@ exceptionCode e = case e of
   NoProgramFound{} -> 7620
   BadVersionDb{} -> 8038
   UnknownVersionDb{} -> 1008
+  MissingCoveredInstalledLibrary{} -> 9341
 
 versionRequirement :: VersionRange -> String
 versionRequirement range
@@ -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."

Cabal/src/Distribution/Simple/Flag.hs

@@ -29,6 +29,7 @@ module Distribution.Simple.Flag
   , flagToMaybe
   , flagToList
   , maybeToFlag
+  , mergeListFlag
   , BooleanFlag (..)
   ) where
 
@@ -143,6 +144,11 @@ maybeToFlag :: Maybe a -> Flag a
 maybeToFlag Nothing = NoFlag
 maybeToFlag (Just x) = Flag x
 
+-- | Merge the elements of a list 'Flag' with another list 'Flag'.
+mergeListFlag :: Flag [a] -> Flag [a] -> Flag [a]
+mergeListFlag currentFlags v =
+  Flag $ concat (flagToList currentFlags ++ flagToList v)
+
 -- | Types that represent boolean flags.
 class BooleanFlag a where
   asBool :: a -> Bool

Cabal/src/Distribution/Simple/GHC/BuildGeneric.hs

@@ -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
@@ -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
@@ -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 (gbuildName bm)
+        | isCoverageEnabled = toFlag $ Hpc.mixDir (tmpDir </> extraCompilationArtifacts) way
         | otherwise = mempty
 
   rpaths <- getRPaths lbi clbi

Cabal/src/Distribution/Simple/GHC/BuildOrRepl.hs

@@ -7,10 +7,8 @@ import Control.Monad (forM_)
 import qualified Distribution.ModuleName as ModuleName
 import Distribution.Package
 import Distribution.PackageDescription as PD
-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
@@ -28,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
@@ -97,15 +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
-      -- TODO: Historically HPC files have been put into a directory which
-      -- has the package name.  I'm going to avoid changing this for
-      -- now, but it would probably be better for this to be the
-      -- component ID instead...
-      pkg_name = prettyShow (PD.package pkg_descr)
-      distPref = fromFlag $ configDistPref $ configFlags lbi
       hpcdir way
         | forRepl = mempty -- HPC is not supported in ghci
-        | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way pkg_name
+        | isCoverageEnabled = toFlag $ Hpc.mixDir (libTargetDir </> extraCompilationArtifacts) way
         | otherwise = mempty
 
   createDirectoryIfMissingVerbose verbosity True libTargetDir

Cabal/src/Distribution/Simple/GHCJS.hs

@@ -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
@@ -481,7 +481,7 @@ buildOrReplLib
   -> Library
   -> ComponentLocalBuildInfo
   -> IO ()
-buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do
+buildOrReplLib mReplFlags verbosity numJobs _pkg_descr lbi lib clbi = do
   let uid = componentUnitId clbi
       libTargetDir = componentBuildDir lbi clbi
       whenVanillaLib forceVanilla =
@@ -515,15 +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
-      -- TODO: Historically HPC files have been put into a directory which
-      -- has the package name.  I'm going to avoid changing this for
-      -- now, but it would probably be better for this to be the
-      -- component ID instead...
-      pkg_name = prettyShow (PD.package pkg_descr)
-      distPref = fromFlag $ configDistPref $ configFlags lbi
       hpcdir way
         | forRepl = mempty -- HPC is not supported in ghci
-        | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way pkg_name
+        | isCoverageEnabled = toFlag $ Hpc.mixDir (libTargetDir </> extraCompilationArtifacts) way
         | otherwise = mempty
 
   createDirectoryIfMissingVerbose verbosity True libTargetDir
@@ -1240,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 (gbuildName bm)
+        | isCoverageEnabled = toFlag $ Hpc.mixDir (tmpDir </> extraCompilationArtifacts) way
         | otherwise = mempty
 
   rpaths <- getRPaths lbi clbi