Fix #6856 Add --reach option to dot and ls dependencies commands

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 <packages>` 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:
 

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 <depth>` option to limit the depth;
 *   all relevant packages are included in the output. Pass the
     `--prune <packages>` option to exclude the specified packages (including
-    project packages), where `<packages>` is a list of package names separated
-    by commas;
+    project packages). Pass the `--reach <packages>` option to exclude packages
+    (including project packages) that cannot reach any of the specified packages
+    in the dependency graph. In both cases, `<packages>` 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

doc/commands/ls_command.md

@@ -69,8 +69,10 @@ By default:
     `--depth <depth>` option to limit the depth;
 *   all relevant packages are included in the output. Pass the
     `--prune <packages>` option to exclude the specified packages (including
-    project packages), where `<packages>` is a list of package names separated
-    by commas;
+    project packages). Pass the `--reach <packages>` option to exclude packages
+    (including project packages) that cannot reach any of the specified packages
+    in the dependency graph. In both cases, `<packages>` 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

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

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 =

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))