07/08: graph: Add '--max-depth'.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 5b32ad4f6f555d305659cee825879df075b06331
Author: Ludovic Courtès <ludovic.courtes@inria.fr>
AuthorDate: Fri Sep 17 10:13:15 2021 +0200

    graph: Add '--max-depth'.
    
    * guix/graph.scm (export-graph): Add #:max-depth and honor it, adding
    'depths' argument to 'loop'.
    * guix/scripts/graph.scm (%options, show-help): Add '--max-depth'.
    (%default-options): Add 'max-depth'.
    (guix-graph): Pass #:max-depth to 'export-graph'.
    * tests/graph.scm ("package DAG, limited depth"): New test.
    * doc/guix.texi (Invoking guix graph): Document it.
---
 doc/guix.texi          | 14 ++++++++++++++
 guix/graph.scm         | 45 ++++++++++++++++++++++++++++-----------------
 guix/scripts/graph.scm | 11 ++++++++++-
 tests/graph.scm        | 21 ++++++++++++++++++++-
 4 files changed, 72 insertions(+), 19 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index cd8e249..b15a45a 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -12644,6 +12644,20 @@ $ guix graph --path -t references emacs libunistring
 /gnu/store/@dots{}-libunistring-0.9.10
 @end example
 
+Sometimes you still want to visualize the graph but would like to trim
+it so it can actually be displayed.  One way to do it is via the
+@option{--max-depth} (or @option{-M}) option, which lets you specify the
+maximum depth of the graph.  In the example below, we visualize only
+@code{libreoffice} and the nodes whose distance to @code{libreoffice} is
+at most 2:
+
+@example
+guix graph -M 2 libreoffice | xdot -f fdp -
+@end example
+
+Mind you, that's still a big ball of spaghetti, but at least
+@command{dot} can render it quickly and it can be browsed somewhat.
+
 The available options are the following:
 
 @table @option
diff --git a/guix/graph.scm b/guix/graph.scm
index 0d4cd83..3a1cab2 100644
--- a/guix/graph.scm
+++ b/guix/graph.scm
@@ -337,11 +337,12 @@ nodeArray.push(nodes[\"~a\"]);~%"
 
 (define* (export-graph sinks port
                        #:key
-                       reverse-edges? node-type
+                       reverse-edges? node-type (max-depth +inf.0)
                        (backend %graphviz-backend))
   "Write to PORT the representation of the DAG with the given SINKS, using the
 given BACKEND.  Use NODE-TYPE to traverse the DAG.  When REVERSE-EDGES? is
-true, draw reverse arrows."
+true, draw reverse arrows.  Do not represent nodes whose distance to one of
+the SINKS is greater than MAX-DEPTH."
   (match backend
     (($ <graph-backend> _ _ emit-prologue emit-epilogue emit-node emit-edge)
      (emit-prologue (node-type-name node-type) port)
@@ -349,6 +350,7 @@ true, draw reverse arrows."
      (match node-type
        (($ <node-type> node-identifier node-label node-edges)
         (let loop ((nodes   sinks)
+                   (depths  (make-list (length sinks) 0))
                    (visited (set)))
           (match nodes
             (()
@@ -356,20 +358,29 @@ true, draw reverse arrows."
                (emit-epilogue port)
                (store-return #t)))
             ((head . tail)
-             (mlet %store-monad ((id (node-identifier head)))
-               (if (set-contains? visited id)
-                   (loop tail visited)
-                   (mlet* %store-monad ((dependencies (node-edges head))
-                                        (ids          (mapm %store-monad
-                                                            node-identifier
-                                                            dependencies)))
-                     (emit-node id (node-label head) port)
-                     (for-each (lambda (dependency dependency-id)
-                                 (if reverse-edges?
-                                     (emit-edge dependency-id id port)
-                                     (emit-edge id dependency-id port)))
-                               dependencies ids)
-                     (loop (append dependencies tail)
-                           (set-insert id visited)))))))))))))
+             (match depths
+               ((depth . depths)
+                (mlet %store-monad ((id (node-identifier head)))
+                  (if (set-contains? visited id)
+                      (loop tail depths visited)
+                      (mlet* %store-monad ((dependencies
+                                            (if (= depth max-depth)
+                                                (return '())
+                                                (node-edges head)))
+                                           (ids
+                                            (mapm %store-monad
+                                                  node-identifier
+                                                  dependencies)))
+                        (emit-node id (node-label head) port)
+                        (for-each (lambda (dependency dependency-id)
+                                    (if reverse-edges?
+                                        (emit-edge dependency-id id port)
+                                        (emit-edge id dependency-id port)))
+                                  dependencies ids)
+                        (loop (append dependencies tail)
+                              (append (make-list (length dependencies)
+                                                 (+ 1 depth))
+                                  depths)
+                              (set-insert id visited)))))))))))))))
 
 ;;; graph.scm ends here
diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm
index 66de824..439fae0 100644
--- a/guix/scripts/graph.scm
+++ b/guix/scripts/graph.scm
@@ -500,6 +500,10 @@ package modules, while attempting to retain user package 
modules."
                  (lambda (opt name arg result)
                    (alist-cons 'backend (lookup-backend arg)
                                result)))
+         (option '(#\M "max-depth") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'max-depth (string->number* arg)
+                               result)))
          (option '("list-backends") #f #f
                  (lambda (opt name arg result)
                    (list-backends)
@@ -538,6 +542,8 @@ Emit a representation of the dependency graph of 
PACKAGE...\n"))
   (display (G_ "
       --list-types       list the available graph types"))
   (display (G_ "
+      --max-depth=DEPTH  limit to nodes within distance DEPTH"))
+  (display (G_ "
       --path             display the shortest path between the given nodes"))
   (display (G_ "
   -e, --expression=EXPR  consider the package EXPR evaluates to"))
@@ -559,6 +565,7 @@ Emit a representation of the dependency graph of 
PACKAGE...\n"))
 (define %default-options
   `((node-type . ,%package-node-type)
     (backend   . ,%graphviz-backend)
+    (max-depth . +inf.0)
     (system    . ,(%current-system))))
 
 
@@ -582,6 +589,7 @@ Emit a representation of the dependency graph of 
PACKAGE...\n"))
 
     (with-store store
       (let* ((transform (options->transformation opts))
+             (max-depth (assoc-ref opts 'max-depth))
              (items     (filter-map (match-lambda
                                       (('argument . (? store-path? item))
                                        item)
@@ -613,7 +621,8 @@ nodes (given ~a)~%")
                 (export-graph (concatenate nodes)
                               (current-output-port)
                               #:node-type type
-                              #:backend backend)))
+                              #:backend backend
+                              #:max-depth max-depth)))
           #:system (assq-ref opts 'system)))))
   #t)
 
diff --git a/tests/graph.scm b/tests/graph.scm
index e374dad..fadac26 100644
--- a/tests/graph.scm
+++ b/tests/graph.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès 
<ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès 
<ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -94,6 +94,25 @@ edges."
                           (list p3 p3 p2)
                           (list p2 p1 p1))))))))
 
+(test-assert "package DAG, limited depth"
+  (let-values (((backend nodes+edges) (make-recording-backend)))
+    (let* ((p1 (dummy-package "p1"))
+           (p2 (dummy-package "p2" (inputs `(("p1" ,p1)))))
+           (p3 (dummy-package "p3" (inputs `(("p1" ,p1)))))
+           (p4 (dummy-package "p4" (inputs `(("p2" ,p2) ("p3" ,p3))))))
+      (run-with-store %store
+        (export-graph (list p4) 'port
+                      #:max-depth 1
+                      #:node-type %package-node-type
+                      #:backend backend))
+      ;; We should see nothing more than these 3 packages.
+      (let-values (((nodes edges) (nodes+edges)))
+        (and (equal? nodes (map package->tuple (list p4 p2 p3)))
+             (equal? edges
+                     (map edge->tuple
+                          (list p4 p4)
+                          (list p2 p3))))))))
+
 (test-assert "reverse package DAG"
   (let-values (((backend nodes+edges) (make-recording-backend)))
     (run-with-store %store