From: "Ludovic Courtès" <ludo@gnu.org>
To: 41164@debbugs.gnu.org
Cc: "Ludovic Courtès" <ludo@gnu.org>
Subject: [bug#41164] [PATCH 1/3] graph: reference/referrer node types work with graph traversal.
Date: Sun, 10 May 2020 01:27:37 +0200 [thread overview]
Message-ID: <20200509232739.29016-1-ludo@gnu.org> (raw)
In-Reply-To: <20200509230401.28364-1-ludo@gnu.org>
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.
---
guix/scripts/graph.scm | 23 ++++++++++++++++-------
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
--
2.26.2
next prev parent reply other threads:[~2020-05-09 23:28 UTC|newest]
Thread overview: 17+ messages / expand[flat|nested] mbox.gz Atom feed top
2020-05-09 23:04 [bug#41164] [PATCH 0/3] Add 'guix graph --path' Ludovic Courtès
2020-05-09 23:27 ` Ludovic Courtès [this message]
2020-05-09 23:27 ` [bug#41164] [PATCH 2/3] graph: Add 'shortest-path' Ludovic Courtès
2020-05-09 23:27 ` [bug#41164] [PATCH 3/3] guix graph: Add '--path' Ludovic Courtès
2020-05-10 10:51 ` [bug#41164] [PATCH 0/3] Add 'guix graph --path' zimoun
2020-05-10 14:16 ` Ludovic Courtès
2020-05-10 16:18 ` zimoun
2020-05-10 19:27 ` zimoun
2020-05-11 12:33 ` Ludovic Courtès
2020-05-11 12:36 ` Ludovic Courtès
2020-05-11 14:02 ` zimoun
2020-05-11 20:55 ` Ludovic Courtès
2020-05-11 22:13 ` zimoun
2020-05-12 8:41 ` Ludovic Courtès
2020-05-12 11:56 ` zimoun
2020-05-11 21:36 ` bug#41164: " Ludovic Courtès
2020-05-10 23:45 ` [bug#41164] Fix pipe 'guix show' zimoun
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://guix.gnu.org/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20200509232739.29016-1-ludo@gnu.org \
--to=ludo@gnu.org \
--cc=41164@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).