summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix/graph.scm55
-rw-r--r--tests/graph.scm38
2 files changed, 92 insertions, 1 deletions
diff --git a/guix/graph.scm b/guix/graph.scm
index 05325ba0a6..a39208e7f9 100644
--- a/guix/graph.scm
+++ b/guix/graph.scm
@@ -21,8 +21,11 @@
#:use-module (guix monads)
#:use-module (guix records)
#:use-module (guix sets)
+ #:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-26)
#:use-module (ice-9 match)
+ #:use-module (ice-9 vlist)
#:export (node-type
node-type?
node-type-identifier
@@ -32,6 +35,10 @@
node-type-name
node-type-description
+ node-edges
+ node-back-edges
+ node-transitive-edges
+
%graphviz-backend
graph-backend?
graph-backend
@@ -63,6 +70,54 @@
(name node-type-name) ;string
(description node-type-description)) ;string
+(define (%node-edges type nodes cons-edge)
+ (with-monad %store-monad
+ (match type
+ (($ <node-type> identifier label node-edges)
+ (define (add-edge node edges)
+ (>>= (node-edges node)
+ (lambda (nodes)
+ (return (fold (cut cons-edge node <> <>)
+ edges nodes)))))
+
+ (mlet %store-monad ((edges (foldm %store-monad
+ add-edge vlist-null nodes)))
+ (return (lambda (node)
+ (reverse (vhash-foldq* cons '() node edges)))))))))
+
+(define (node-edges type nodes)
+ "Return, as a monadic value, a one-argument procedure that, given a node of TYPE,
+returns its edges. NODES is taken to be the sinks of the global graph."
+ (%node-edges type nodes
+ (lambda (source target edges)
+ (vhash-consq source target edges))))
+
+(define (node-back-edges type nodes)
+ "Return, as a monadic value, a one-argument procedure that, given a node of TYPE,
+returns its back edges. NODES is taken to be the sinks of the global graph."
+ (%node-edges type nodes
+ (lambda (source target edges)
+ (vhash-consq target source edges))))
+
+(define (node-transitive-edges nodes node-edges)
+ "Return the list of nodes directly or indirectly connected to NODES
+according to the NODE-EDGES procedure. NODE-EDGES must be a one-argument
+procedure that, given a node, returns its list of direct dependents; it is
+typically returned by 'node-edges' or 'node-back-edges'."
+ (let loop ((nodes (append-map node-edges nodes))
+ (result '())
+ (visited (setq)))
+ (match nodes
+ (()
+ result)
+ ((head . tail)
+ (if (set-contains? visited head)
+ (loop tail result visited)
+ (let ((edges (node-edges head)))
+ (loop (append edges tail)
+ (cons head result)
+ (set-insert head visited))))))))
+
;;;
;;; Graphviz export.
diff --git a/tests/graph.scm b/tests/graph.scm
index ed5849f4da..9c9e3666b7 100644
--- a/tests/graph.scm
+++ b/tests/graph.scm
@@ -25,8 +25,12 @@
#:use-module (guix store)
#:use-module (guix monads)
#:use-module (guix build-system gnu)
+ #:use-module (guix build-system trivial)
#:use-module (guix gexp)
+ #:use-module (guix utils)
#:use-module (gnu packages)
+ #:use-module (gnu packages base)
+ #:use-module (gnu packages guile)
#:use-module (gnu packages bootstrap)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
@@ -111,7 +115,7 @@ edges."
".drv")))
implicit)))))))
-(test-assert "bag DAG"
+(test-assert "bag DAG" ;a big town in Iraq
(let-values (((backend nodes+edges) (make-recording-backend)))
(let ((p (dummy-package "p")))
(run-with-store %store
@@ -188,6 +192,38 @@ edges."
(list out txt))
(equal? edges `((,out ,txt)))))))))))
+(test-assert "node-edges"
+ (run-with-store %store
+ (let ((packages (fold-packages cons '())))
+ (mlet %store-monad ((edges (node-edges %package-node-type packages)))
+ (return (and (null? (edges grep))
+ (lset= eq?
+ (edges guile-2.0)
+ (match (package-direct-inputs guile-2.0)
+ (((labels packages _ ...) ...)
+ packages)))))))))
+
+(test-assert "node-transitive-edges + node-back-edges"
+ (run-with-store %store
+ (let ((packages (fold-packages cons '()))
+ (bootstrap? (lambda (package)
+ (string-contains
+ (location-file (package-location package))
+ "bootstrap.scm")))
+ (trivial? (lambda (package)
+ (eq? (package-build-system package)
+ trivial-build-system))))
+ (mlet %store-monad ((edges (node-back-edges %bag-node-type packages)))
+ (let* ((glibc (canonical-package glibc))
+ (dependents (node-transitive-edges (list glibc) edges))
+ (diff (lset-difference eq? packages dependents)))
+ ;; All the packages depend on libc, except bootstrap packages and
+ ;; some that use TRIVIAL-BUILD-SYSTEM.
+ (return (null? (remove (lambda (package)
+ (or (trivial? package)
+ (bootstrap? package)))
+ diff))))))))
+
(test-end "graph")