Implement v2-gen-bounds function

cabal-install/cabal-install.cabal

@@ -118,6 +118,7 @@ library
         Distribution.Client.CmdTarget
         Distribution.Client.CmdTest
         Distribution.Client.CmdUpdate
+        Distribution.Client.CmdGenBounds
         Distribution.Client.Compat.Directory
         Distribution.Client.Compat.ExecutablePath
         Distribution.Client.Compat.Orphans

cabal-install/src/Distribution/Client/CmdGenBounds.hs

@@ -0,0 +1,256 @@
+{-# LANGUAGE NamedFieldPuns #-}
+
+module Distribution.Client.CmdGenBounds
+  ( genBounds
+  , genBoundsCommand
+  , genBoundsAction
+  , GenBoundsFlags (..)
+  , defaultGenBoundsFlags
+  ) where
+
+import Distribution.Client.Compat.Prelude
+import Prelude ()
+
+import qualified Data.Map as Map
+
+import Control.Monad (mapM_)
+
+import Distribution.Client.Errors
+
+import Distribution.Client.ProjectPlanning hiding (pruneInstallPlanToTargets)
+import Distribution.Client.ProjectPlanning.Types
+import Distribution.Client.Types.ConfiguredId (confInstId)
+import Distribution.Client.Utils hiding (pvpize)
+import Distribution.InstalledPackageInfo (InstalledPackageInfo, installedComponentId)
+import Distribution.Package
+import Distribution.PackageDescription
+import Distribution.Simple.Utils
+import Distribution.Version
+
+import Distribution.Client.Setup (CommonSetupFlags (..), ConfigFlags (..), GlobalFlags (..))
+
+-- Project orchestration imports
+
+import Distribution.Client.CmdErrorMessages
+import Distribution.Client.GenBounds
+import qualified Distribution.Client.InstallPlan as InstallPlan
+import Distribution.Client.NixStyleOptions
+import Distribution.Client.ProjectFlags
+import Distribution.Client.ProjectOrchestration
+import Distribution.Client.ScriptUtils
+import Distribution.Client.TargetProblem
+import Distribution.Simple.Command
+import Distribution.Simple.Flag
+import Distribution.Types.Component
+import Distribution.Verbosity
+
+-- | The data type for gen-bounds command flags
+data GenBoundsFlags = GenBoundsFlags {}
+
+-- | Default values for the gen-bounds flags
+defaultGenBoundsFlags :: GenBoundsFlags
+defaultGenBoundsFlags = GenBoundsFlags{}
+
+-- | The @gen-bounds@ command definition
+genBoundsCommand :: CommandUI (NixStyleFlags GenBoundsFlags)
+genBoundsCommand =
+  CommandUI
+    { commandName = "v2-gen-bounds"
+    , commandSynopsis = "Generate dependency bounds for packages in the project."
+    , commandUsage = usageAlternatives "v2-gen-bounds" ["[TARGETS] [FLAGS]"]
+    , commandDescription = Just $ \_ ->
+        "Generate PVP-compliant dependency bounds for packages in the project."
+    , commandNotes = Just $ \pname ->
+        "Examples:\n"
+          ++ "  "
+          ++ pname
+          ++ " v2-gen-bounds\n"
+          ++ "    Generate bounds for the package in the current directory "
+          ++ "or all packages in the project\n"
+          ++ "  "
+          ++ pname
+          ++ " v2-gen-bounds pkgname\n"
+          ++ "    Generate bounds for the package named pkgname in the project\n"
+          ++ "  "
+          ++ pname
+          ++ " v2-gen-bounds ./pkgfoo\n"
+          ++ "    Generate bounds for the package in the ./pkgfoo directory\n"
+    , commandDefaultFlags = defaultNixStyleFlags defaultGenBoundsFlags
+    , commandOptions =
+        removeIgnoreProjectOption
+          . nixStyleOptions (const [])
+    }
+
+-- | The action for the @gen-bounds@ command when used in a project context.
+genBoundsAction :: NixStyleFlags GenBoundsFlags -> [String] -> GlobalFlags -> IO ()
+genBoundsAction flags targetStrings globalFlags =
+  withContextAndSelectors RejectNoTargets Nothing flags targetStrings globalFlags OtherCommand $ \targetCtx ctx targetSelectors -> do
+    let verbosity = fromFlagOrDefault normal (setupVerbosity $ configCommonFlags $ configFlags flags)
+
+    baseCtx <- case targetCtx of
+      ProjectContext -> return ctx
+      GlobalContext -> return ctx
+      ScriptContext path _ ->
+        dieWithException verbosity $
+          GenBoundsDoesNotSupportScript path
+
+    let ProjectBaseContext{distDirLayout, cabalDirLayout, projectConfig, localPackages} = baseCtx
+
+    -- Step 1: Create the install plan for the project.
+    (_, elaboratedPlan, _, _, _) <-
+      rebuildInstallPlan
+        verbosity
+        distDirLayout
+        cabalDirLayout
+        projectConfig
+        localPackages
+        Nothing
+
+    -- Step 2: Resolve the targets for the gen-bounds command.
+    targets <-
+      either (reportGenBoundsTargetProblems verbosity) return $
+        resolveTargets
+          selectPackageTargets
+          selectComponentTarget
+          elaboratedPlan
+          Nothing
+          targetSelectors
+
+    -- Step 3: Prune the install plan to the targets.
+    let elaboratedPlan' =
+          pruneInstallPlanToTargets
+            TargetActionBuild
+            targets
+            elaboratedPlan
+
+    let
+      -- Step 4a: Find the local packages from the install plan. These are the
+      -- candidates for which we will generate bounds.
+      localPkgs :: [ElaboratedConfiguredPackage]
+      localPkgs = mapMaybe (InstallPlan.foldPlanPackage (const Nothing) (\p -> Just p)) (InstallPlan.toList elaboratedPlan')
+
+      -- Step 4b: Extract which versions we chose for each package from the pruned install plan.
+      pkgVersionMap :: Map.Map ComponentId PackageIdentifier
+      pkgVersionMap = Map.fromList (map (InstallPlan.foldPlanPackage externalVersion localVersion) (InstallPlan.toList elaboratedPlan'))
+
+      externalVersion :: InstalledPackageInfo -> (ComponentId, PackageIdentifier)
+      externalVersion pkg = (installedComponentId pkg, packageId pkg)
+
+      localVersion :: ElaboratedConfiguredPackage -> (ComponentId, PackageIdentifier)
+      localVersion pkg = (elabComponentId pkg, packageId pkg)
+
+    let genBoundsActionForPkg :: ElaboratedConfiguredPackage -> [GenBoundsResult]
+        genBoundsActionForPkg pkg =
+          -- Step 5: Match up the user specified targets with the local packages.
+          case Map.lookup (installedUnitId pkg) targets of
+            Nothing -> []
+            Just tgts ->
+              map (\(tgt, _) -> getBoundsForComponent tgt pkg pkgVersionMap) tgts
+
+    -- Process each package to find the ones needing bounds
+    let boundsActions = concatMap genBoundsActionForPkg localPkgs
+
+    if (any isBoundsNeeded boundsActions)
+      then do
+        notice verbosity boundsNeededMsg
+        mapM_ (renderBoundsResult verbosity) boundsActions
+      else notice verbosity "All bounds up-to-date"
+
+data GenBoundsResult = GenBoundsResult PackageIdentifier ComponentTarget (Maybe [PackageIdentifier])
+
+isBoundsNeeded :: GenBoundsResult -> Bool
+isBoundsNeeded (GenBoundsResult _ _ Nothing) = False
+isBoundsNeeded _ = True
+
+renderBoundsResult :: Verbosity -> GenBoundsResult -> IO ()
+renderBoundsResult verbosity (GenBoundsResult pid tgt bounds) =
+  case bounds of
+    Nothing ->
+      notice
+        verbosity
+        ("Congratulations, all dependencies for " ++ prettyShow (packageName pid) ++ ":" ++ showComponentTarget pid tgt ++ " have upper bounds!")
+    Just pkgBounds -> do
+      notice verbosity $
+        "For component " ++ prettyShow (pkgName pid) ++ ":" ++ showComponentTarget pid tgt ++ ":"
+      let padTo = maximum $ map (length . unPackageName . packageName) pkgBounds
+      traverse_ (notice verbosity . (++ ",") . showBounds padTo) pkgBounds
+
+-- | Process a single BuildInfo to identify and report missing upper bounds
+getBoundsForComponent
+  :: ComponentTarget
+  -> ElaboratedConfiguredPackage
+  -> Map.Map ComponentId PackageIdentifier
+  -> GenBoundsResult
+getBoundsForComponent tgt pkg pkgVersionMap =
+  if null needBounds
+    then boundsResult Nothing
+    else -- All the things we depend on.
+
+      let componentDeps = elabLibDependencies pkg
+          -- Match these up to package names, this is a list of Package name to versions.
+          -- Now just match that up with what the user wrote in the build-depends section.
+          depsWithVersions = mapMaybe (\cid -> Map.lookup (confInstId $ fst cid) pkgVersionMap) componentDeps
+          isNeeded = hasElem needBounds . packageName
+       in boundsResult (Just (filter isNeeded depsWithVersions))
+  where
+    pd = elabPkgDescription pkg
+    -- Extract the build-depends for the right part of the cabal file.
+    bi = buildInfoForTarget pd tgt
+
+    -- We need to generate bounds if
+    -- \* the dependency does not have an upper bound
+    -- \* the dependency is not the same package as the one we are processing
+    boundFilter dep =
+      (not (hasUpperBound (depVerRange dep)))
+        && packageName pd /= depPkgName dep
+
+    -- The dependencies that need bounds.
+    needBounds = map depPkgName $ filter boundFilter $ targetBuildDepends bi
+
+    boundsResult = GenBoundsResult (packageId pkg) tgt
+
+buildInfoForTarget :: PackageDescription -> ComponentTarget -> BuildInfo
+buildInfoForTarget pd (ComponentTarget cname _) = componentBuildInfo $ getComponent pd cname
+
+-- | This defines what a 'TargetSelector' means for the @gen-bounds@ command.
+-- Copy of selectPackageTargets from CmdBuild.hs
+selectPackageTargets
+  :: TargetSelector
+  -> [AvailableTarget k]
+  -> Either TargetProblem' [k]
+selectPackageTargets targetSelector targets
+  -- If there are any buildable targets then we select those
+  | not (null targetsBuildable) =
+      Right targetsBuildable
+  -- If there are targets but none are buildable then we report those
+  | not (null targets) =
+      Left (TargetProblemNoneEnabled targetSelector targets')
+  -- If there are no targets at all then we report that
+  | otherwise =
+      Left (TargetProblemNoTargets targetSelector)
+  where
+    targets' = forgetTargetsDetail targets
+    targetsBuildable =
+      selectBuildableTargetsWith
+        (buildable targetSelector)
+        targets
+
+    -- When there's a target filter like "pkg:tests" then we do select tests,
+    -- but if it's just a target like "pkg" then we don't build tests unless
+    -- they are requested by default (i.e. by using --enable-tests)
+    buildable (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False
+    buildable (TargetAllPackages Nothing) TargetNotRequestedByDefault = False
+    buildable _ _ = True
+
+-- | For a 'TargetComponent' 'TargetSelector', check if the component can be
+-- selected. Copy of selectComponentTarget from CmdBuild.hs
+selectComponentTarget
+  :: SubComponentTarget
+  -> AvailableTarget k
+  -> Either TargetProblem' k
+selectComponentTarget = selectComponentTargetBasic
+
+-- | Report target problems for gen-bounds command
+reportGenBoundsTargetProblems :: Verbosity -> [TargetProblem'] -> IO a
+reportGenBoundsTargetProblems verbosity problems =
+  reportTargetProblems verbosity "gen-bounds" problems

cabal-install/src/Distribution/Client/Errors.hs

@@ -186,6 +186,7 @@ data CabalInstallException
   | MissingPackageList Repo.RemoteRepo
   | CmdPathAcceptsNoTargets
   | CmdPathCommandDoesn'tSupportDryRun
+  | GenBoundsDoesNotSupportScript FilePath
   deriving (Show)
 
 exceptionCodeCabalInstall :: CabalInstallException -> Int
@@ -338,6 +339,7 @@ exceptionCodeCabalInstall e = case e of
   MissingPackageList{} -> 7160
   CmdPathAcceptsNoTargets{} -> 7161
   CmdPathCommandDoesn'tSupportDryRun -> 7163
+  GenBoundsDoesNotSupportScript{} -> 7164
 
 exceptionMessageCabalInstall :: CabalInstallException -> String
 exceptionMessageCabalInstall e = case e of
@@ -860,6 +862,8 @@ exceptionMessageCabalInstall e = case e of
     "The 'path' command accepts no target arguments."
   CmdPathCommandDoesn'tSupportDryRun ->
     "The 'path' command doesn't support the flag '--dry-run'."
+  GenBoundsDoesNotSupportScript{} ->
+    "The 'gen-bounds' command does not support script targets."
 
 instance Exception (VerboseException CabalInstallException) where
   displayException :: VerboseException CabalInstallException -> [Char]

cabal-install/src/Distribution/Client/GenBounds.hs

@@ -10,6 +10,8 @@
 -- The cabal gen-bounds command for generating PVP-compliant version bounds.
 module Distribution.Client.GenBounds
   ( genBounds
+  , boundsNeededMsg
+  , showBounds
   ) where
 
 import Distribution.Client.Compat.Prelude

cabal-install/src/Distribution/Client/Main.hs

@@ -120,6 +120,7 @@ import qualified Distribution.Client.CmdClean as CmdClean
 import qualified Distribution.Client.CmdConfigure as CmdConfigure
 import qualified Distribution.Client.CmdExec as CmdExec
 import qualified Distribution.Client.CmdFreeze as CmdFreeze
+import qualified Distribution.Client.CmdGenBounds as CmdGenBounds
 import qualified Distribution.Client.CmdHaddock as CmdHaddock
 import qualified Distribution.Client.CmdHaddockProject as CmdHaddockProject
 import qualified Distribution.Client.CmdInstall as CmdInstall
@@ -436,7 +437,6 @@ mainWorker args = do
       , regularCmd initCommand initAction
       , regularCmd userConfigCommand userConfigAction
       , regularCmd CmdPath.pathCommand CmdPath.pathAction
-      , regularCmd genBoundsCommand genBoundsAction
       , regularCmd CmdOutdated.outdatedCommand CmdOutdated.outdatedAction
       , wrapperCmd hscolourCommand hscolourCommonFlags
       , hiddenCmd formatCommand formatAction
@@ -462,7 +462,9 @@ mainWorker args = do
           , newCmd CmdClean.cleanCommand CmdClean.cleanAction
           , newCmd CmdSdist.sdistCommand CmdSdist.sdistAction
           , newCmd CmdTarget.targetCommand CmdTarget.targetAction
+          , newCmd CmdGenBounds.genBoundsCommand CmdGenBounds.genBoundsAction
           , legacyCmd configureExCommand configureAction
+          , legacyCmd genBoundsCommand genBoundsAction
           , legacyCmd buildCommand buildAction
           , legacyCmd replCommand replAction
           , legacyCmd freezeCommand freezeAction

cabal-testsuite/PackageTests/GenBounds/Issue6290/cabal.out

@@ -1,3 +1,3 @@
 # cabal gen-bounds
 Resolving dependencies...
-Congratulations, all your dependencies have upper bounds!
+All bounds up-to-date

cabal-testsuite/PackageTests/GenBounds/Issue7504/cabal.project

@@ -0,0 +1,2 @@
+packages: package-a
+          package-b

cabal-testsuite/PackageTests/GenBounds/Issue7504/cabal.test.hs

@@ -0,0 +1,11 @@
+import System.Directory (setCurrentDirectory)
+import Test.Cabal.Prelude
+
+main = cabalTest $ recordMode DoNotRecord $ do
+    r <- cabal' "gen-bounds" ["all"]
+    assertOutputContains "For component package-a:lib:package-a:" r
+    assertOutputContains "For component package-b:lib:package-b:" r
+    assertOutputContains "For component package-b:exe:package-b:" r
+    assertOutputContains "text >=" r
+    assertOutputContains "package-a >= 0.1.0 && < 0.2" r
+

cabal-testsuite/PackageTests/GenBounds/Issue7504/package-a/LICENSE

@@ -0,0 +1,28 @@
+Copyright (c) 2023, Cabal Team
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+    * Neither the name of Cabal Team nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

cabal-testsuite/PackageTests/GenBounds/Issue7504/package-a/package-a.cabal

@@ -0,0 +1,15 @@
+cabal-version:       2.2
+name:                package-a
+version:             0.1.0.0
+synopsis:            A simple package for testing gen-bounds
+license:             BSD-3-Clause
+license-file:        LICENSE
+author:              Cabal Team
+maintainer:          [email protected]
+build-type:          Simple
+
+library
+  default-language:    Haskell2010
+  hs-source-dirs:      src
+  exposed-modules:     ModuleA
+  build-depends:       base >= 4.8 && < 5, text

cabal-testsuite/PackageTests/GenBounds/Issue7504/package-a/src/ModuleA.hs

@@ -0,0 +1,5 @@
+module ModuleA (getMessage) where
+
+-- | Return a simple greeting message
+getMessage :: String
+getMessage = "Hello from package-a!"