diff options
| -rw-r--r-- | guix/graph.scm | 55 | ||||
| -rw-r--r-- | tests/graph.scm | 38 |
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") |