From 8fb583714f78d1b283523ef7edbb6e098946182f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 21 Nov 2015 13:12:02 +0100 Subject: Add (guix graph). * guix/scripts/graph.scm (, , emit-prologue) (emit-epilogue, emit-node, emit-edge, %graphviz-backend, export-graph): Move to... * guix/graph.scm: ... here. New file. * guix/scripts/system.scm, tests/graph.scm: Use it. * Makefile.am (MODULES): Add it. --- tests/graph.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'tests/graph.scm') diff --git a/tests/graph.scm b/tests/graph.scm index f454b06351..ed5849f4da 100644 --- a/tests/graph.scm +++ b/tests/graph.scm @@ -18,6 +18,7 @@ (define-module (test-graph) #:use-module (guix tests) + #:use-module (guix graph) #:use-module (guix scripts graph) #:use-module (guix packages) #:use-module (guix derivations) -- cgit v1.2.3 From 923d846c4dfe0f51357d3329697f54c779148dde Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 21 Nov 2015 14:48:34 +0100 Subject: graph: Add procedures to query a node's edges. * guix/graph.scm (%node-edges, node-edges, node-back-edges) (node-transitive-edges): New procedures. * tests/graph.scm ("node-edges") ("node-transitive-edges + node-back-edges"): New tests. --- guix/graph.scm | 55 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ tests/graph.scm | 38 +++++++++++++++++++++++++++++++++++++- 2 files changed, 92 insertions(+), 1 deletion(-) (limited to 'tests/graph.scm') 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 + (($ 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") -- cgit v1.2.3 From 38b92daa81d6c5eca77ae0cc3d454da46a64b48a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 23 Nov 2015 23:31:53 +0100 Subject: graph: Add '%bag-with-origins-node-type'. * guix/scripts/graph.scm (bag-node-edges): Remove 'filter' call. Add case for 'origin'. (%bag-node-type)[edges]: Add filtering here. (%bag-with-origins-node-type): New variable. (%node-types): Add it. * tests/graph.scm ("bag DAG, including origins"): New test. * tests/guix-graph.sh: Add 'bag-with-origins'. * doc/guix.texi (Invoking guix graph): Document it. --- doc/guix.texi | 3 +++ guix/scripts/graph.scm | 48 ++++++++++++++++++++++++++++++++++++------------ tests/graph.scm | 26 ++++++++++++++++++++++++++ tests/guix-graph.sh | 2 +- 4 files changed, 66 insertions(+), 13 deletions(-) (limited to 'tests/graph.scm') diff --git a/doc/guix.texi b/doc/guix.texi index a56bda9c79..5eb6720934 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -4631,6 +4631,9 @@ here, for conciseness. Similar to @code{bag-emerged}, but this time including all the bootstrap dependencies. +@item bag-with-origins +Similar to @code{bag}, but also showing origins and their dependencies. + @item derivations This is the most detailed representation: It shows the DAG of derivations (@pxref{Derivations}) and plain store items. Compared to diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index f607ebee31..9255f0018a 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -30,11 +30,13 @@ #:use-module (gnu packages) #:use-module (guix sets) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-37) #:use-module (ice-9 match) #:export (%package-node-type %bag-node-type + %bag-with-origins-node-type %bag-emerged-node-type %derivation-node-type %reference-node-type @@ -104,17 +106,23 @@ file name." low)))))) (define (bag-node-edges thing) - "Return the list of dependencies of THING, a package or origin, etc." - (if (package? thing) - (match (bag-direct-inputs (package->bag thing)) - (((labels things . outputs) ...) - (filter-map (match-lambda - ((? package? p) p) - ;; XXX: Here we choose to filter out origins, files, - ;; etc. Replace "#f" with "x" to reinstate them. - (x #f)) - things))) - '())) + "Return the list of dependencies of THING, a package or origin. +Dependencies may include packages, origin, and file names." + (cond ((package? thing) + (match (bag-direct-inputs (package->bag thing)) + (((labels things . outputs) ...) + things))) + ((origin? thing) + (cons (origin-patch-guile thing) + (if (or (pair? (origin-patches thing)) + (origin-snippet thing)) + (match (origin-patch-inputs thing) + (#f '()) + (((labels dependencies _ ...) ...) + (delete-duplicates dependencies eq?))) + '()))) + (else + '()))) (define %bag-node-type ;; Type for the traversal of package nodes via the "bag" representation, @@ -124,7 +132,22 @@ file name." (description "the DAG of packages, including implicit inputs") (identifier bag-node-identifier) (label node-full-name) - (edges (lift1 bag-node-edges %store-monad)))) + (edges (lift1 (compose (cut filter package? <>) bag-node-edges) + %store-monad)))) + +(define %bag-with-origins-node-type + (node-type + (name "bag-with-origins") + (description "the DAG of packages and origins, including implicit inputs") + (identifier bag-node-identifier) + (label node-full-name) + (edges (lift1 (lambda (thing) + (filter (match-lambda + ((? package?) #t) + ((? origin?) #t) + (_ #f)) + (bag-node-edges thing))) + %store-monad)))) (define standard-package-set (memoize @@ -239,6 +262,7 @@ substitutes." ;; List of all the node types. (list %package-node-type %bag-node-type + %bag-with-origins-node-type %bag-emerged-node-type %derivation-node-type %reference-node-type)) diff --git a/tests/graph.scm b/tests/graph.scm index 9c9e3666b7..ad8aea0ada 100644 --- a/tests/graph.scm +++ b/tests/graph.scm @@ -134,6 +134,32 @@ edges." (((labels packages) ...) (map package-full-name packages)))))))) +(test-assert "bag DAG, including origins" + (let-values (((backend nodes+edges) (make-recording-backend))) + (let* ((m (lambda* (uri hash-type hash name #:key system) + (text-file "foo-1.2.3.tar.gz" "This is a fake!"))) + (o (origin (method m) (uri "the-uri") (sha256 #vu8(0 1 2)))) + (p (dummy-package "p" (source o)))) + (run-with-store %store + (export-graph (list p) 'port + #:node-type %bag-with-origins-node-type + #:backend backend)) + ;; We should see O among the nodes, with an edge coming from P. + (let-values (((nodes edges) (nodes+edges))) + (run-with-store %store + (mlet %store-monad ((o* (lower-object o)) + (p* (lower-object p))) + (return + (and (find (match-lambda + ((file "the-uri") #t) + (_ #f)) + nodes) + (find (match-lambda + ((source target) + (and (string=? source (derivation-file-name p*)) + (string=? target o*)))) + edges))))))))) + (test-assert "derivation DAG" (let-values (((backend nodes+edges) (make-recording-backend))) (run-with-store %store diff --git a/tests/guix-graph.sh b/tests/guix-graph.sh index e0cbebb753..4d5a755bc1 100644 --- a/tests/guix-graph.sh +++ b/tests/guix-graph.sh @@ -24,7 +24,7 @@ guix graph --version for package in guile-bootstrap coreutils python do - for graph in package bag-emerged bag + for graph in package bag-emerged bag bag-with-origins do guix graph -t "$graph" "$package" | grep "$package" done -- cgit v1.2.3