summaryrefslogtreecommitdiff
path: root/guix/graph.scm
diff options
context:
space:
mode:
Diffstat (limited to 'guix/graph.scm')
-rw-r--r--guix/graph.scm45
1 files changed, 28 insertions, 17 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