From ed01de6ec33fcc98f924c51b15337f65ff51b28c Mon Sep 17 00:00:00 2001
From: gbaz <gershomb@gmail.com>
Date: Tue, 7 Sep 2021 02:07:31 -0400
Subject: [PATCH] handle conditionals in duplicate module checks (#7616)
* handle conditionals in duplicate module checks
* fix silly bug
* changelog
* Update Check.hs
Co-authored-by: Gershom Bazerman <gershom@arista.com>
Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com>
---
.../Distribution/PackageDescription/Check.hs | 56 +++++++++----------
Cabal/src/Distribution/Types/CondTree.hs | 13 +++++
changelog.d/pr-7616 | 10 ++++
3 files changed, 48 insertions(+), 31 deletions(-)
create mode 100644 changelog.d/pr-7616
diff --git a/Cabal/src/Distribution/PackageDescription/Check.hs b/Cabal/src/Distribution/PackageDescription/Check.hs
index fc1c196f06..449c535583 100644
--- a/Cabal/src/Distribution/PackageDescription/Check.hs
+++ b/Cabal/src/Distribution/PackageDescription/Check.hs
@@ -155,6 +155,7 @@ checkPackage gpkg mpkg =
++ checkUnicodeXFields gpkg
++ checkPathsModuleExtensions pkg
++ checkSetupVersions gpkg
+ ++ checkDuplicateModules gpkg
where
pkg = fromMaybe (flattenPackageDescription gpkg) mpkg
@@ -241,13 +242,8 @@ checkLibrary :: PackageDescription -> Library -> [PackageCheck]
checkLibrary pkg lib =
catMaybes [
- check (not (null moduleDuplicates)) $
- PackageBuildImpossible $
- "Duplicate modules in library: "
- ++ commaSep (map prettyShow moduleDuplicates)
-
-- TODO: This check is bogus if a required-signature was passed through
- , check (null (explicitLibModules lib) && null (reexportedModules lib)) $
+ check (null (explicitLibModules lib) && null (reexportedModules lib)) $
PackageDistSuspiciousWarn $
showLibraryName (libName lib) ++ " does not expose any modules"
@@ -278,10 +274,6 @@ checkLibrary pkg lib =
| specVersion pkg >= ver = Nothing
| otherwise = check cond pc
- -- TODO: not sure if this check is always right in Backpack
- moduleDuplicates = dups (explicitLibModules lib ++
- map moduleReexportName (reexportedModules lib))
-
allExplicitIncludes :: L.HasBuildInfo a => a -> [FilePath]
allExplicitIncludes x = view L.includes x ++ view L.installIncludes x
@@ -307,11 +299,6 @@ checkExecutable pkg exe =
"The package uses a C/C++/obj-C source file for the 'main-is' field. "
++ "To use this feature you must specify 'cabal-version: >= 1.18'."
- , check (not (null moduleDuplicates)) $
- PackageBuildImpossible $
- "Duplicate modules in executable '" ++ prettyShow (exeName exe) ++ "': "
- ++ commaSep (map prettyShow moduleDuplicates)
-
-- check that all autogen-modules appear on other-modules
, check
(not $ and $ map (flip elem (exeModules exe)) (exeModulesAutogen exe)) $
@@ -324,8 +311,6 @@ checkExecutable pkg exe =
(not $ and $ map (flip elem (view L.includes exe)) (view L.autogenIncludes exe)) $
PackageBuildImpossible "An include in 'autogen-includes' is not in 'includes'."
]
- where
- moduleDuplicates = dups (exeModules exe)
checkTestSuite :: PackageDescription -> TestSuite -> [PackageCheck]
checkTestSuite pkg test =
@@ -345,11 +330,6 @@ checkTestSuite pkg test =
++ commaSep (map prettyShow knownTestTypes)
_ -> Nothing
- , check (not $ null moduleDuplicates) $
- PackageBuildImpossible $
- "Duplicate modules in test suite '" ++ prettyShow (testName test) ++ "': "
- ++ commaSep (map prettyShow moduleDuplicates)
-
, check mainIsWrongExt $
PackageBuildImpossible $
"The 'main-is' field must specify a '.hs' or '.lhs' file "
@@ -374,8 +354,6 @@ checkTestSuite pkg test =
PackageBuildImpossible "An include in 'autogen-includes' is not in 'includes'."
]
where
- moduleDuplicates = dups $ testModules test
-
mainIsWrongExt = case testInterface test of
TestSuiteExeV10 _ f -> not $ fileExtensionSupportedLanguage f
_ -> False
@@ -402,11 +380,6 @@ checkBenchmark _pkg bm =
++ commaSep (map prettyShow knownBenchmarkTypes)
_ -> Nothing
- , check (not $ null moduleDuplicates) $
- PackageBuildImpossible $
- "Duplicate modules in benchmark '" ++ prettyShow (benchmarkName bm) ++ "': "
- ++ commaSep (map prettyShow moduleDuplicates)
-
, check mainIsWrongExt $
PackageBuildImpossible $
"The 'main-is' field must specify a '.hs' or '.lhs' file "
@@ -425,8 +398,6 @@ checkBenchmark _pkg bm =
PackageBuildImpossible "An include in 'autogen-includes' is not in 'includes'."
]
where
- moduleDuplicates = dups $ benchmarkModules bm
-
mainIsWrongExt = case benchmarkInterface bm of
BenchmarkExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"]
_ -> False
@@ -2158,6 +2129,29 @@ checkSetupVersions pkg =
++ "not sure what upper bound to use then use the next major "
++ "version."
+checkDuplicateModules :: GenericPackageDescription -> [PackageCheck]
+checkDuplicateModules pkg =
+ concatMap checkLib (maybe id (:) (condLibrary pkg) . map snd $ condSubLibraries pkg)
+ ++ concatMap checkExe (map snd $ condExecutables pkg)
+ ++ concatMap checkTest (map snd $ condTestSuites pkg)
+ ++ concatMap checkBench (map snd $ condBenchmarks pkg)
+ where
+ -- the duplicate modules check is has not been thoroughly vetted for backpack
+ checkLib = checkDups "library" (\l -> explicitLibModules l ++ map moduleReexportName (reexportedModules l))
+ checkExe = checkDups "executable" exeModules
+ checkTest = checkDups "test suite" testModules
+ checkBench = checkDups "benchmark" benchmarkModules
+ checkDups s getModules t =
+ let libMap = foldCondTree Map.empty
+ (\(_,v) -> Map.fromListWith (+) . map (\x -> (x,(1::Int))) $ getModules v )
+ (Map.unionWith (+)) -- if a module may occur in nonexclusive branches count it twice
+ (Map.unionWith max) -- a module occurs the max of times it might appear in exclusive branches
+ t
+ dupLibs = Map.keys $ Map.filter (>1) libMap
+ in if null dupLibs
+ then []
+ else [PackageBuildImpossible $ "Duplicate modules in " ++ s ++ ": " ++ commaSep (map prettyShow dupLibs)]
+
-- ------------------------------------------------------------
-- * Utils
-- ------------------------------------------------------------
diff --git a/Cabal/src/Distribution/Types/CondTree.hs b/Cabal/src/Distribution/Types/CondTree.hs
index b99ac8f166..8fd233658f 100644
--- a/Cabal/src/Distribution/Types/CondTree.hs
+++ b/Cabal/src/Distribution/Types/CondTree.hs
@@ -10,6 +10,7 @@ module Distribution.Types.CondTree (
CondBranch(..),
condIfThen,
condIfThenElse,
+ foldCondTree,
mapCondTree,
mapTreeConstrs,
mapTreeConds,
@@ -179,3 +180,15 @@ ignoreConditions :: (Semigroup a, Semigroup c) => CondTree v c a -> (a, c)
ignoreConditions (CondNode a c ifs) = foldl (<>) (a, c) $ concatMap f ifs
where f (CondBranch _ t me) = ignoreConditions t
: maybeToList (fmap ignoreConditions me)
+
+
+-- | Flatten a CondTree. This will traverse the CondTree by taking all
+-- possible paths into account, but merging inclusive when two paths
+-- may co-exist, and exclusively when the paths are an if/else
+foldCondTree :: forall b c a v. b -> ((c, a) -> b) -> (b -> b -> b) -> (b -> b -> b) -> CondTree v c a -> b
+foldCondTree e u mergeInclusive mergeExclusive = goTree
+ where
+ goTree :: CondTree v c a -> b
+ goTree (CondNode a c ifs) = u (c, a) `mergeInclusive` foldl goBranch e ifs
+ goBranch :: b -> CondBranch v c a -> b
+ goBranch acc (CondBranch _ t mt) = mergeInclusive acc (maybe (goTree t) (mergeExclusive (goTree t) . goTree) mt)
diff --git a/changelog.d/pr-7616 b/changelog.d/pr-7616
new file mode 100644
index 0000000000..2d8520f19f
--- /dev/null
+++ b/changelog.d/pr-7616
@@ -0,0 +1,10 @@
+synopsis: Handle conditionals in duplicate module checks
+packages: Cabal
+prs: #7616
+issues: #4629 #7525
+
+description: {
+
+Improves `cabal check` logic for duplicate modules to take into account conditional branches. If a module appears on both sides of an `if/else` clause in a cabal file, it is now correctly not reported as a duplicate.
+
+}
--
GitLab