From 38b92daa81d6c5eca77ae0cc3d454da46a64b48a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Mon, 23 Nov 2015 23:31:53 +0100
Subject: [PATCH] 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(-)

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 @@ (define-module (guix scripts graph)
   #: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 @@ (define (bag-node-identifier thing)
                       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 @@ (define %bag-node-type
    (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 @@ (define %node-types
   ;; 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 @@ (define (edge->tuple source target)
                  (((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