diff options
| -rw-r--r-- | guix/scripts/graph.scm | 23 | ||||
| -rw-r--r-- | tests/graph.scm | 27 |
2 files changed, 43 insertions, 7 deletions
diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index fca1e3777c..d69dace14f 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -307,6 +307,14 @@ derivation graph"))))))) ;;; DAG of residual references (aka. run-time dependencies). ;;; +(define intern + (mlambda (str) + "Intern STR, a string denoting a store item." + ;; This is necessary for %REFERENCE-NODE-TYPE and %REFERRER-NODE-TYPE + ;; because their nodes are strings but the (guix graph) traversal + ;; procedures expect to be able to compare nodes with 'eq?'. + str)) + (define ensure-store-items ;; Return a list of store items as a monadic value based on the given ;; argument, which may be a store item or a package. @@ -316,10 +324,10 @@ derivation graph"))))))) (mlet %store-monad ((drv (package->derivation package))) (return (match (derivation->output-paths drv) (((_ . file-names) ...) - file-names))))) + (map intern file-names)))))) ((? store-path? item) (with-monad %store-monad - (return (list item)))) + (return (list (intern item))))) (x (raise (condition (&message (message "unsupported argument for \ @@ -333,18 +341,19 @@ substitutes." (guard (c ((store-protocol-error? c) (match (substitutable-path-info store (list item)) ((info) - (values (substitutable-references info) store)) + (values (map intern (substitutable-references info)) + store)) (() (leave (G_ "references for '~a' are not known~%") item))))) - (values (references store item) store)))) + (values (map intern (references store item)) store)))) (define %reference-node-type (node-type (name "references") (description "the DAG of run-time dependencies (store references)") (convert ensure-store-items) - (identifier (lift1 identity %store-monad)) + (identifier (lift1 intern %store-monad)) (label store-path-package-name) (edges references*))) @@ -353,14 +362,14 @@ substitutes." (lambda (item) "Return the referrers of ITEM, except '.drv' files." (mlet %store-monad ((items (referrers item))) - (return (remove derivation-path? items)))))) + (return (map intern (remove derivation-path? items))))))) (define %referrer-node-type (node-type (name "referrers") (description "the DAG of referrers in the store") (convert ensure-store-items) - (identifier (lift1 identity %store-monad)) + (identifier (lift1 intern %store-monad)) (label store-path-package-name) (edges non-derivation-referrers))) diff --git a/tests/graph.scm b/tests/graph.scm index 402847102f..983a6ed654 100644 --- a/tests/graph.scm +++ b/tests/graph.scm @@ -31,6 +31,7 @@ #:use-module (guix utils) #:use-module (gnu packages) #:use-module (gnu packages base) + #:use-module (gnu packages bootstrap) #:use-module (gnu packages guile) #:use-module (gnu packages libunistring) #:use-module (gnu packages bootstrap) @@ -358,6 +359,32 @@ edges." (return (lset= eq? (node-transitive-edges (list p2) edges) (list p1a p1b p0))))))) +(test-assert "node-transitive-edges, references" + (run-with-store %store + (mlet* %store-monad ((d0 (package->derivation %bootstrap-guile)) + (d1 (gexp->derivation "d1" + #~(begin + (mkdir #$output) + (symlink #$%bootstrap-guile + (string-append + #$output "/l"))))) + (d2 (gexp->derivation "d2" + #~(begin + (mkdir #$output) + (symlink #$d1 + (string-append + #$output "/l"))))) + (_ (built-derivations (list d2))) + (->node -> (node-type-convert %reference-node-type)) + (o2 (->node (derivation->output-path d2))) + (o1 (->node (derivation->output-path d1))) + (o0 (->node (derivation->output-path d0))) + (edges (node-edges %reference-node-type + (append o0 o1 o2))) + (reqs ((store-lift requisites) o2))) + (return (lset= string=? + (append o2 (node-transitive-edges o2 edges)) reqs))))) + (test-equal "node-reachable-count" '(3 3) (run-with-store %store |