From dea60af728a43ffbbc46a65c4befc8b795de4456 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita Date: Thu, 23 Nov 2023 19:07:44 +0000 Subject: [PATCH] Drop component name from hpc dirs; extend hack to internal libraries TODO: nonIndefiniteComponents --- Cabal/src/Distribution/Simple/GHC.hs | 4 +- Cabal/src/Distribution/Simple/GHCJS.hs | 4 +- Cabal/src/Distribution/Simple/Hpc.hs | 65 +++++++++++--------- Cabal/src/Distribution/Simple/Test/ExeV10.hs | 2 +- Cabal/src/Distribution/Simple/Test/LibV09.hs | 4 +- 5 files changed, 42 insertions(+), 37 deletions(-) diff --git a/Cabal/src/Distribution/Simple/GHC.hs b/Cabal/src/Distribution/Simple/GHC.hs index 3c380a41a86..ba381a253e6 100644 --- 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 index 58194f5ffa3..cc9de70f593 100644 --- 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 index c0a332ff139..b4119c5439f 100644 --- 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 index 04c7e30073a..4ad6d5f5852 100644 --- 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 index b87897bfed7..824bbb61e12 100644 --- 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'