Report default-package-bounds warnings in cabal check

haskell · Jun 14, 2024 · 005a58a · 005a58a
1 parent 5e29bb4
commit 005a58a
Show file tree

Hide file tree

Showing 4 changed files with 53 additions and 8 deletions.
diff --git a/Cabal/src/Distribution/PackageDescription/Check.hs b/Cabal/src/Distribution/PackageDescription/Check.hs
@@ -294,9 +294,11 @@ checkGenericPackageDescription
               . pnPackageId
               . ccNames
           )
+
       let ads =
             maybe [] ((: []) . extractAssocDeps pName) condLibrary_
               ++ map (uncurry extractAssocDeps) condSubLibraries_
+              ++ [Left $ defaultPackageBounds packageDescription_]
 
       case condLibrary_ of
         Just cl ->
@@ -409,6 +411,7 @@ checkPackageDescription
           extraSrcFiles_
           extraTmpFiles_
           extraDocFiles_
+          defaultPackageBounds_
         ) = do
     -- § Sanity checks.
     checkPackageId package_
@@ -520,6 +523,25 @@ checkPackageDescription
     mapM_ (checkGlobFile specVersion_ "." "extra-source-files" . getSymbolicPath) extraSrcFiles_
     mapM_ (checkGlobFile specVersion_ "." "extra-doc-files" . getSymbolicPath) extraDocFiles_
     mapM_ (checkGlobFile specVersion_ rawDataDir "data-files" . getSymbolicPath) dataFiles_
+
+    -- PVP: we check for base and all other deps.
+    (ids, rds) <-
+      partitionDeps
+        []
+        [mkUnqualComponentName "base"]
+        ( mergeDependencies $
+            catMaybes $
+              map
+                ( \x -> case x of
+                    DefaultQualBound{} -> Nothing
+                    DefaultUnqualBound p ver -> Just $ Dependency p ver mainLibSet
+                )
+                defaultPackageBounds_
+        )
+    let ick = const (PackageDistInexcusable BaseNoUpperBounds)
+        rck = PackageDistSuspiciousWarn . MissingUpperBounds CETDefaultPackageBounds
+    checkPVP ick ids
+    checkPVPs rck rds
     where
       checkNull
         :: Monad m
@@ -916,7 +938,7 @@ extractAssocDeps n ct =
    in -- Merging is fine here, remember the specific
       -- library dependencies will be checked branch
       -- by branch.
-      (n, snd a)
+      Right (n, snd a)
 
 -- | August 2022: this function is an oddity due to the historical
 -- GenericPackageDescription/PackageDescription split (check

diff --git a/Cabal/src/Distribution/PackageDescription/Check/Common.hs b/Cabal/src/Distribution/PackageDescription/Check/Common.hs
@@ -52,9 +52,9 @@ checkCustomField (n, _) =
 -- PVP types/functions
 -- ------------------------------------------------------------
 
--- A library name / dependencies association list. Ultimately to be
--- fed to PVP check.
-type AssocDep = (UnqualComponentName, [Dependency])
+-- Either a list of dependencies coming from @default-package-bounds@ or a library
+-- name / dependencies association list. Ultimately to be fed to PVP check.
+type AssocDep = Either [DefaultBound] (UnqualComponentName, [Dependency])
 
 -- Convenience function to partition important dependencies by name. To
 -- be used together with checkPVP. Important: usually “base” or “Cabal”,
@@ -67,7 +67,7 @@ type AssocDep = (UnqualComponentName, [Dependency])
 partitionDeps
   :: Monad m
   => [AssocDep] -- Possibly inherited dependencies, i.e.
-  -- dependencies from internal/main libs.
+  -- dependencies from internal/main libs, and from @default-package-bounds@.
   -> [UnqualComponentName] -- List of package names ("base", "Cabal"…)
   -> [Dependency] -- Dependencies to check.
   -> CheckM m ([Dependency], [Dependency])
@@ -77,23 +77,40 @@ partitionDeps ads ns ds = do
     -- names of our dependencies
     dqs = map unqualName ds
     -- shared targets that match
-    fads = filter (flip elem dqs . fst) ads
+    fads = filter (either (const True) (flip elem dqs . fst)) ads
     -- the names of such targets
-    inNam = nub $ map fst fads :: [UnqualComponentName]
+    inNam = nub $ mapMaybe (either (const Nothing) (Just . fst)) fads :: [UnqualComponentName]
     -- the dependencies of such targets
-    inDep = concatMap snd fads :: [Dependency]
+    inDep =
+      concatMap
+        ( either
+            ( catMaybes
+                . map
+                  ( \x -> case x of
+                      DefaultUnqualBound name ver -> Just $ Dependency name ver mainLibSet
+                      DefaultQualBound{} -> Nothing
+                  )
+            )
+            snd
+        )
+        fads
+        :: [Dependency]
 
   -- We exclude from checks:
   -- 1. dependencies which are shared with main library / a
   --    sublibrary; and of course
   -- 2. the names of main library / sub libraries themselves.
   --
   -- So in myPackage.cabal
+  --
+  -- default-package-bounds: bar < 100
+  --
   -- library
   --      build-depends: text < 5
   -- ⁝
   --      build-depends: myPackage,        ← no warning, internal
   --                     text,             ← no warning, inherited
+  --                     bar,              ← no warning, inherited
   --                     monadacme         ← warning!
   let fFun d =
         notElem (unqualName d) inNam

diff --git a/Cabal/src/Distribution/PackageDescription/Check/Target.hs b/Cabal/src/Distribution/PackageDescription/Check/Target.hs
@@ -13,6 +13,8 @@ module Distribution.PackageDescription.Check.Target
   , checkExecutable
   , checkTestSuite
   , checkBenchmark
+  -- Utils
+  , mergeDependencies
   ) where
 
 import Distribution.Compat.Prelude
@@ -760,6 +762,7 @@ isInternalTarget (CETExecutable{}) = False
 isInternalTarget (CETTest{}) = True
 isInternalTarget (CETBenchmark{}) = True
 isInternalTarget (CETSetup{}) = False
+isInternalTarget (CETDefaultPackageBounds{}) = True
 
 -- ------------------------------------------------------------
 -- Options
@@ -776,6 +779,7 @@ cet2bit (CETExecutable{}) = BITOther
 cet2bit (CETTest{}) = BITTestBench
 cet2bit (CETBenchmark{}) = BITTestBench
 cet2bit CETSetup = BITOther
+cet2bit CETDefaultPackageBounds = BITOther
 
 -- General check on all options (ghc, C, C++, …) for common inaccuracies.
 checkBuildInfoOptions :: Monad m => BITarget -> BuildInfo -> CheckM m ()

diff --git a/Cabal/src/Distribution/PackageDescription/Check/Warning.hs b/Cabal/src/Distribution/PackageDescription/Check/Warning.hs
@@ -746,6 +746,7 @@ data CEType
   | CETTest UnqualComponentName
   | CETBenchmark UnqualComponentName
   | CETSetup
+  | CETDefaultPackageBounds
   deriving (Eq, Ord, Show)
 
 -- | Pretty printing `CEType`.
@@ -757,6 +758,7 @@ ppCET cet = case cet of
   CETTest n -> "test suite" ++ qn n
   CETBenchmark n -> "benchmark" ++ qn n
   CETSetup -> "custom-setup"
+  CETDefaultPackageBounds -> "default package bounds"
   where
     qn :: UnqualComponentName -> String
     qn wn = (" " ++) . quote . prettyShow $ wn