Drop component name from hpc dirs; extend hack to internal libraries

alt-romes · alt-romes · commit dea60af728a4 · 2023-11-23T19:07:46.000Z
TODO: nonIndefiniteComponents
diff --git a/Cabal/src/Distribution/Simple/GHC.hs b/Cabal/src/Distribution/Simple/GHC.hs
@@ -651,7 +651,7 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do
       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 distPref way
         | otherwise = mempty
 
   createDirectoryIfMissingVerbose verbosity True libTargetDir
@@ -1548,7 +1548,7 @@ gbuild verbosity numJobs pkg_descr lbi bm clbi = do
       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 distPref way
         | otherwise = mempty
 
   rpaths <- getRPaths lbi clbi
diff --git a/Cabal/src/Distribution/Simple/GHCJS.hs b/Cabal/src/Distribution/Simple/GHCJS.hs
@@ -523,7 +523,7 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do
       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 distPref way
         | otherwise = mempty
 
   createDirectoryIfMissingVerbose verbosity True libTargetDir
@@ -1243,7 +1243,7 @@ gbuild verbosity numJobs pkg_descr lbi bm clbi = do
       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 distPref way
         | otherwise = mempty
 
   rpaths <- getRPaths lbi clbi
diff --git a/Cabal/src/Distribution/Simple/Hpc.hs b/Cabal/src/Distribution/Simple/Hpc.hs
@@ -73,20 +73,16 @@ mixDir
   -- ^ \"dist/\" prefix
   -> Way
   -> FilePath
-  -- ^ Component name
-  -> FilePath
   -- ^ Directory containing test suite's .mix files
-mixDir distPref way name = hpcDir distPref way </> "mix" </> name
+mixDir distPref way = hpcDir distPref way </> "mix"
 
 tixDir
   :: FilePath
   -- ^ \"dist/\" prefix
   -> Way
   -> FilePath
-  -- ^ Component name
-  -> FilePath
   -- ^ Directory containing test suite's .tix files
-tixDir distPref way name = hpcDir distPref way </> "tix" </> name
+tixDir distPref way = hpcDir distPref way </> "tix"
 
 -- | Path to the .tix file containing a test suite's sum statistics.
 tixFilePath
@@ -97,17 +93,15 @@ tixFilePath
   -- ^ Component name
   -> FilePath
   -- ^ Path to test suite's .tix file
-tixFilePath distPref way name = tixDir distPref way name </> name <.> "tix"
+tixFilePath distPref way name = tixDir distPref way </> name <.> "tix"
 
 htmlDir
   :: FilePath
   -- ^ \"dist/\" prefix
   -> Way
   -> FilePath
-  -- ^ Component name
-  -> FilePath
   -- ^ Path to test suite's HTML markup directory
-htmlDir distPref way name = hpcDir distPref way </> "html" </> name
+htmlDir distPref way = hpcDir distPref way </> "html"
 
 -- | Attempt to guess the way the test suites in this package were compiled
 -- and linked with the library so the correct module interfaces are found.
@@ -139,7 +133,7 @@ markupTest verbosity lbi testDistPref libraryName suite library = do
         hpcProgram
         anyVersion
         (withPrograms lbi)
-    let htmlDir_ = htmlDir testDistPref way testName'
+    let htmlDir_ = htmlDir testDistPref way
     markup
       hpc
       hpcVer
@@ -156,8 +150,9 @@ markupTest verbosity lbi testDistPref libraryName suite library = do
     way = guessWay lbi
     testName' = unUnqualComponentName $ testName suite
     mixDirs =
-      [ mixDir testDistPref way testName'
-      , mixDir (pathToMainLibHpc testDistPref) way libraryName
+      [ mixDir testDistPref way
+      , mixDir (pathToLibHpc testDistPref (PD.libName library)) way
+      -- nonIndefiniteLibraries
       ]
 
 -- | Generate the HTML markup for all of a package's test suites.
@@ -169,8 +164,8 @@ markupPackage
   -> PD.PackageDescription
   -> [TestSuite]
   -> IO ()
-markupPackage verbosity lbi distPref pkg_descr suites = do
-  let tixFiles = map (tixFilePath distPref way) testNames
+markupPackage verbosity lbi testDistPref pkg_descr suites = do
+  let tixFiles = map (tixFilePath testDistPref way) testNames
   tixFilesExist <- traverse doesFileExist tixFiles
   when (and tixFilesExist) $ do
     -- behaviour of 'markup' depends on version, so we need *a* version
@@ -181,8 +176,8 @@ markupPackage verbosity lbi distPref pkg_descr suites = do
         hpcProgram
         anyVersion
         (withPrograms lbi)
-    let outFile = tixFilePath distPref way libraryName
-        htmlDir' = htmlDir distPref way libraryName
+    let outFile = tixFilePath testDistPref way libraryName
+        htmlDir' = htmlDir testDistPref way
         excluded = concatMap testModules suites ++ [main]
     createDirectoryIfMissing True $ takeDirectory outFile
     union hpc verbosity tixFiles outFile excluded
@@ -194,19 +189,19 @@ markupPackage verbosity lbi distPref pkg_descr suites = do
   where
     way = guessWay lbi
     testNames = fmap (unUnqualComponentName . testName) suites
-    mixDirs = mixDir (pathToMainLibHpc distPref) way libraryName : map (mixDir distPref way) testNames
-    included = concatMap (exposedModules) $ PD.allLibraries pkg_descr
+    mixDirs = mixDir testDistPref way : map ((`mixDir` way) . pathToLibHpc testDistPref . PD.libName) (PD.allLibraries pkg_descr)
+    included = concatMap (exposedModules) $ nonIndefiniteLibraries pkg_descr
     libraryName = prettyShow $ PD.package pkg_descr
 
--- | A (non-exported) hack to determine the path to the main-lib hpc directory
--- given the testsuite's dist prefix.
+-- | A (non-exported) hack to determine the path to the main and internal libs
+-- directory given the testsuite's dist prefix.
 --
 -- We use this function when constructing calls to `hpc markup` since otherwise
--- having cabal-install communicate the path to the main lib dist-dir when
--- building the test component, via the Setup.hs interface, is far more
--- complicated.
-pathToMainLibHpc :: FilePath -> FilePath
-pathToMainLibHpc distPref = distPrefBuild
+-- having cabal-install communicate the path to the main and sub libraries
+-- dist-dir when building the test component, via the Setup.hs interface, is
+-- far more complicated.
+pathToLibHpc :: FilePath -> PD.LibraryName -> FilePath
+pathToLibHpc testDistPref libname = distPrefLib
   where
     -- This is a hack for HPC over test suites, needed to match the directory
     -- where HPC saves and reads .mix files when the main library of the same
@@ -218,16 +213,26 @@ pathToMainLibHpc distPref = distPrefBuild
     -- both @hpc@ and @ghc@. For non-default optimization levels, the path
     -- suffix is one element longer and the extra path element needs
     -- to be preserved.
-    distPrefElements = splitDirectories distPref
-    distPrefBuild = case drop (length distPrefElements - 3) distPrefElements of
+    distPrefElements = splitDirectories testDistPref
+    distPrefLib = case drop (length distPrefElements - 3) distPrefElements of
       ["t", _, "noopt"] ->
         joinPath $
           take (length distPrefElements - 3) distPrefElements
+            ++ [distSuffixInternalLib]
             ++ ["noopt"]
       ["t", _, "opt"] ->
         joinPath $
           take (length distPrefElements - 3) distPrefElements
+            ++ [distSuffixInternalLib]
             ++ ["opt"]
       [_, "t", _] ->
-        joinPath $ take (length distPrefElements - 2) distPrefElements
-      _ -> distPref
+        joinPath $
+          take (length distPrefElements - 2) distPrefElements
+            ++ [distSuffixInternalLib]
+      _ -> error "pathToLibHpc: Expecting `testDirPref` to be the dist prefix of a test-suite component"
+    distSuffixInternalLib = case libname of
+      PD.LMainLibName -> ""
+      PD.LSubLibName slname -> "l" </> unUnqualComponentName slname
+
+nonIndefiniteLibraries :: PD.PackageDescription -> [Library]
+nonIndefiniteLibraries = PD.allLibraries
diff --git a/Cabal/src/Distribution/Simple/Test/ExeV10.hs b/Cabal/src/Distribution/Simple/Test/ExeV10.hs
@@ -51,7 +51,7 @@ runTest
 runTest pkg_descr lbi clbi flags suite = do
   let isCoverageEnabled = LBI.testCoverage lbi
       way = guessWay lbi
-      tixDir_ = tixDir distPref way testName'
+      tixDir_ = tixDir distPref way
 
   pwd <- getCurrentDirectory
   existingEnv <- getEnvironment
diff --git a/Cabal/src/Distribution/Simple/Test/LibV09.hs b/Cabal/src/Distribution/Simple/Test/LibV09.hs
@@ -80,12 +80,12 @@ runTest pkg_descr lbi clbi flags suite = do
 
   -- Remove old .tix files if appropriate.
   unless (fromFlag $ testKeepTix flags) $ do
-    let tDir = tixDir distPref way testName'
+    let tDir = tixDir distPref way
     exists' <- doesDirectoryExist tDir
     when exists' $ removeDirectoryRecursive tDir
 
   -- Create directory for HPC files.
-  createDirectoryIfMissing True $ tixDir distPref way testName'
+  createDirectoryIfMissing True $ tixDir distPref way
 
   -- Write summary notices indicating start of test suite
   notice verbosity $ summarizeSuiteStart testName'
