graph: reference/referrer node types work with graph traversal.

The graph traversal procedures in (guix graph) assume that nodes can be
compared with 'eq?', which was not the case for nodes of
%REFERENCE-NODE-TYPE and %REFERRER-NODE-TYPE (strings).

* guix/scripts/graph.scm (intern): New procedure.
(ensure-store-items, references*)
(%reference-node-type, non-derivation-referrers)
(%referrer-node-type): Use it on all store items.
* tests/graph.scm ("node-transitive-edges, references"): New test.
This commit is contained in:
Ludovic Courtès 2020-05-10 00:04:59 +02:00
parent c2b2c19a7b
commit 7240202136
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 43 additions and 7 deletions

View file

@ -307,6 +307,14 @@ (define %derivation-node-type
;;; 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 @@ (define ensure-store-items
(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 @@ (define (references* item)
(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 @@ (define non-derivation-referrers
(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)))

View file

@ -31,6 +31,7 @@ (define-module (test-graph)
#: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 @@ (define (edge->tuple source target)
(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