From 724020213664239ec5c92d04f5fee44c25408a7f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Sun, 10 May 2020 00:04:59 +0200
Subject: 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.
---
 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
-- 
cgit v1.2.3