From 7dc9582eb73726273cf9511c54a4f1eaa52067e4 Mon Sep 17 00:00:00 2001 From: Mike Pilgrem Date: Fri, 6 Mar 2026 21:59:47 +0000 Subject: [PATCH] Fix #6856 Add --reach option to dot and ls dependencies commands --- ChangeLog.md | 5 ++++- doc/commands/dot_command.md | 10 +++++---- doc/commands/ls_command.md | 6 +++-- src/Stack/DependencyGraph.hs | 40 +++++++++++++++++++++++++++++++--- src/Stack/Options/DotParser.hs | 8 +++++++ src/Stack/Types/DotOpts.hs | 3 +++ 6 files changed, 62 insertions(+), 10 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 6257019cac..4ba4b18917 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -11,7 +11,7 @@ Major changes: Behavior changes: * Stack's default Nix integration now includes the `cacert` Nix package, in - order to support Stack's use of `crypton-x509-system >= 1.6.8`. + order to support Stack's use of `crypton-x509-system >= 1.6.8`. Other enhancements: @@ -20,6 +20,9 @@ Other enhancements: in parallel when possible. Supported, by default, by GHC 9.10.1 or later. The option is considered experiemental because, on Linux only, musl and non-musl semaphores are incompatible. +* Add option `--reach ` to Stack's `dot` and `ls dependencies` + commands, to prune packages that cannot reach any of the specified packages in + the dependency graph. Bug fixes: diff --git a/doc/commands/dot_command.md b/doc/commands/dot_command.md index 618f9fc813..9edddb781a 100644 --- a/doc/commands/dot_command.md +++ b/doc/commands/dot_command.md @@ -4,8 +4,8 @@ ~~~text stack dot [--[no-]external] [--[no-]include-base] [--depth DEPTH] - [--prune PACKAGES] [TARGET] [--flag PACKAGE:[-]FLAG] - [--test] [--bench] [--global-hints] + [--prune PACKAGES] [--reach PACKAGES] [TARGET] + [--flag PACKAGE:[-]FLAG] [--test] [--bench] [--global-hints] ~~~ A package and its dependencies and the direct dependency relationships between @@ -28,8 +28,10 @@ By default: `--depth ` option to limit the depth; * all relevant packages are included in the output. Pass the `--prune ` option to exclude the specified packages (including - project packages), where `` is a list of package names separated - by commas; + project packages). Pass the `--reach ` option to exclude packages + (including project packages) that cannot reach any of the specified packages + in the dependency graph. In both cases, `` is a list of package + names separated by commas; * for all relevant project packages, relevant dependencies are included in the output. However, each project package for which dependencies are included can be specified as a target argument. The argument uses the same format as diff --git a/doc/commands/ls_command.md b/doc/commands/ls_command.md index 1d6c952b93..9485b849d1 100644 --- a/doc/commands/ls_command.md +++ b/doc/commands/ls_command.md @@ -69,8 +69,10 @@ By default: `--depth ` option to limit the depth; * all relevant packages are included in the output. Pass the `--prune ` option to exclude the specified packages (including - project packages), where `` is a list of package names separated - by commas; + project packages). Pass the `--reach ` option to exclude packages + (including project packages) that cannot reach any of the specified packages + in the dependency graph. In both cases, `` is a list of package + names separated by commas; * for all relevant project packages, relevant dependencies are included in the output. However, each project package for which dependencies are included can be specified as a target argument. The argument uses the same format as diff --git a/src/Stack/DependencyGraph.hs b/src/Stack/DependencyGraph.hs index c95be77ed9..2ad8e4db4f 100644 --- a/src/Stack/DependencyGraph.hs +++ b/src/Stack/DependencyGraph.hs @@ -117,9 +117,12 @@ createPrunedDependencyGraph dotOpts = withDotConfig dotOpts $ do localNames <- view $ buildConfigL . to (Map.keysSet . (.smWanted.project)) logDebug "Creating dependency graph" (compiler, resultGraph) <- createDependencyGraph dotOpts - let pkgsToPrune = if dotOpts.includeBase - then dotOpts.prune - else Set.insert "base" dotOpts.prune + let pkgsToPrune = Set.union + ( if dotOpts.includeBase + then dotOpts.prune + else Set.insert "base" dotOpts.prune + ) + (nonParentDependencies resultGraph dotOpts.reach) prunedGraph = pruneGraph localNames pkgsToPrune resultGraph logDebug "Returning pruned dependency graph" pure (compiler, localNames, prunedGraph) @@ -413,5 +416,36 @@ pruneUnreachable dontPrune = fixpoint prune reachable k = k `F.elem` dontPrune || k `Set.member` reachables reachables = F.fold (fst <$> graph') +nonParentDependencies :: + F.Foldable f + => Map PackageName (Set PackageName, a) + -> f PackageName + -> Set PackageName +nonParentDependencies graph names + | F.null names = Set.empty + | otherwise = + Set.difference (Map.keysSet graph) (backwardReachable names graph) + +backwardReachable :: + F.Foldable f + => f PackageName + -> Map PackageName (Set PackageName, a) + -> Set PackageName +backwardReachable names graph = go Set.empty (F.toList names) + where + reverseGraph = + Map.fromListWith Set.union + [ (dep, Set.singleton name) + | (name, (deps, _)) <- Map.toList graph + , dep <- Set.toList deps + ] + + go seen [] = seen + go seen (x : xs) + | x `Set.member` seen = go seen xs + | otherwise = + let parents = Map.findWithDefault Set.empty x reverseGraph + in go (Set.insert x seen) (Set.toList parents <> xs) + localPackageToPackage :: LocalPackage -> Package localPackageToPackage lp = fromMaybe lp.package lp.testBench diff --git a/src/Stack/Options/DotParser.hs b/src/Stack/Options/DotParser.hs index 56dc22c592..3572c50464 100644 --- a/src/Stack/Options/DotParser.hs +++ b/src/Stack/Options/DotParser.hs @@ -34,6 +34,7 @@ dotOptsParser externalDefault = DotOpts <*> includeBase <*> depthLimit <*> fmap (maybe Set.empty $ Set.fromList . splitNames) prunedPkgs + <*> fmap (maybe Set.empty $ Set.fromList . splitNames) reachPkgs <*> targetsParser <*> flagsParser <*> testTargets @@ -59,6 +60,13 @@ dotOptsParser externalDefault = DotOpts <> help "Prune specified package(s). PACKAGES is a comma-separated list of \ \package names." )) + reachPkgs = optional (strOption + ( long "reach" + <> metavar "PACKAGES" + <> help "Prune packages that cannot reach any of the specified package(s) \ + \in the dependency graph. PACKAGES is a comma-separated list of \ + \package names." + )) targetsParser :: Parser [Text] targetsParser = diff --git a/src/Stack/Types/DotOpts.hs b/src/Stack/Types/DotOpts.hs index a0683c6f60..dd8f4c9ba0 100644 --- a/src/Stack/Types/DotOpts.hs +++ b/src/Stack/Types/DotOpts.hs @@ -27,6 +27,9 @@ data DotOpts = DotOpts -- fixpoint , prune :: !(Set PackageName) -- ^ Package names to prune from the graph + , reach :: !(Set PackageName) + -- ^ If not empty, packages in the pruned graph must be able to reach one or + -- more of these packages , dotTargets :: [Text] -- ^ Stack TARGETs to trace dependencies for , flags :: !(Map ApplyCLIFlag (Map FlagName Bool))