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.

2 files changed, 38 insertions, 18 deletions

diff --git a/guix/graph.scm b/guix/graph.scm
index 0d4cd83667..3a1cab244b 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 66de824ef4..439fae0b52 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)