Add 'guix graph'.

* guix/scripts/graph.scm, tests/graph.scm, tests/guix-graph.sh,
  doc/images/coreutils-bag-graph.dot, doc/images/coreutils-graph.dot: New
  files.
* Makefile.am (MODULES): Add guix/scripts/graph.scm.
  (SH_TESTS): Add tests/guix-graph.sh.
  (SCM_TESTS): Add tests/graph.scm.
* doc.am (DOT_FILES, DOT_VECTOR_GRAPHICS): New variables.
  (EXTRA_DIST): Use them.
  (dist_infoimage_DATA): Use $(DOT_FILES).
  (pdf-local, info-local, ps-local): Likewise.
* doc/guix.texi (Packages with Multiple Outputs): Add cross-reference to 'guix
  graph'.
  (Invoking guix gc): Likewise.
  (Invoking guix graph): New section.

1 files changed, 193 insertions, 0 deletions

diff --git a/tests/graph.scm b/tests/graph.scm
new file mode 100644
index 00000000000..f454b063519
--- /dev/null
+++ b/tests/graph.scm
@@ -0,0 +1,193 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (test-graph)
+  #:use-module (guix tests)
+  #:use-module (guix scripts graph)
+  #:use-module (guix packages)
+  #:use-module (guix derivations)
+  #:use-module (guix store)
+  #:use-module (guix monads)
+  #:use-module (guix build-system gnu)
+  #:use-module (guix gexp)
+  #:use-module (gnu packages)
+  #:use-module (gnu packages bootstrap)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-64))
+
+(define %store
+  (open-connection-for-tests))
+
+(define (make-recording-backend)
+  "Return a <graph-backend> and a thunk that returns the recorded nodes and
+edges."
+  (let ((nodes '())
+        (edges '()))
+    (define (record-node id label port)
+      (set! nodes (cons (list id label) nodes)))
+    (define (record-edge source target port)
+      (set! edges (cons (list source target) edges)))
+    (define (return)
+      (values (reverse nodes) (reverse edges)))
+
+    (values (graph-backend (const #t) (const #t)
+                           record-node record-edge)
+            return)))
+
+(define (package->tuple package)
+  "Return a tuple representing PACKAGE as produced by %PACKAGE-NODE-TYPE."
+  (list (object-address package)
+        (package-full-name package)))
+
+(define (edge->tuple source target)
+  "Likewise for an edge from SOURCE to TARGET."
+  (list (object-address source)
+        (object-address target)))
+
+
+(test-begin "graph")
+
+(test-assert "package DAG"
+  (let-values (((backend nodes+edges) (make-recording-backend)))
+    (let* ((p1 (dummy-package "p1"))
+           (p2 (dummy-package "p2" (inputs `(("p1" ,p1)))))
+           (p3 (dummy-package "p3" (inputs `(("p2" ,p2) ("p1", p1))))))
+      (run-with-store %store
+        (export-graph (list p3) 'port
+                      #:node-type %package-node-type
+                      #:backend backend))
+      ;; We should see nothing more than these 3 packages.
+      (let-values (((nodes edges) (nodes+edges)))
+        (and (equal? nodes (map package->tuple (list p3 p2 p1)))
+             (equal? edges
+                     (map edge->tuple
+                          (list p3 p3 p2)
+                          (list p2 p1 p1))))))))
+
+(test-assert "bag-emerged DAG"
+  (let-values (((backend nodes+edges) (make-recording-backend)))
+    (let ((p        (dummy-package "p"))
+          (implicit (map (match-lambda
+                           ((label package) package))
+                         (standard-packages))))
+      (run-with-store %store
+        (export-graph (list p) 'port
+                      #:node-type %bag-emerged-node-type
+                      #:backend backend))
+      ;; We should see exactly P and IMPLICIT, with one edge from P to each
+      ;; element of IMPLICIT.
+      (let-values (((nodes edges) (nodes+edges)))
+        (and (equal? (match nodes
+                       (((labels names) ...)
+                        names))
+                     (map package-full-name (cons p implicit)))
+             (equal? (match edges
+                       (((sources destinations) ...)
+                        (zip (map store-path-package-name sources)
+                             (map store-path-package-name destinations))))
+                     (map (lambda (destination)
+                            (list "p-0.drv"
+                                  (string-append
+                                   (package-full-name destination)
+                                   ".drv")))
+                          implicit)))))))
+
+(test-assert "bag DAG"
+  (let-values (((backend nodes+edges) (make-recording-backend)))
+    (let ((p (dummy-package "p")))
+      (run-with-store %store
+        (export-graph (list p) 'port
+                      #:node-type %bag-node-type
+                      #:backend backend))
+      ;; We should see P, its implicit inputs as well as the whole DAG, which
+      ;; should include bootstrap binaries.
+      (let-values (((nodes edges) (nodes+edges)))
+        (every (lambda (name)
+                 (find (cut string=? name <>)
+                       (match nodes
+                         (((labels names) ...)
+                          names))))
+               (match %bootstrap-inputs
+                 (((labels packages) ...)
+                  (map package-full-name packages))))))))
+
+(test-assert "derivation DAG"
+  (let-values (((backend nodes+edges) (make-recording-backend)))
+    (run-with-store %store
+      (mlet* %store-monad ((txt   (text-file "text-file" "Hello!"))
+                           (guile (package->derivation %bootstrap-guile))
+                           (drv   (gexp->derivation "output"
+                                                    #~(symlink #$txt #$output)
+                                                    #:guile-for-build
+                                                    guile)))
+        ;; We should get at least these 3 nodes and corresponding edges.
+        (mbegin %store-monad
+          (export-graph (list drv) 'port
+                        #:node-type %derivation-node-type
+                        #:backend backend)
+          (let-values (((nodes edges) (nodes+edges)))
+            ;; XXX: For some reason we need to throw in some 'basename'.
+            (return (and (match nodes
+                           (((ids labels) ...)
+                            (let ((ids (map basename ids)))
+                              (every (lambda (item)
+                                       (member (basename item) ids))
+                                     (list txt
+                                           (derivation-file-name drv)
+                                           (derivation-file-name guile))))))
+                         (every (cut member <>
+                                     (map (lambda (edge)
+                                            (map basename edge))
+                                          edges))
+                                (list (map (compose basename derivation-file-name)
+                                           (list drv guile))
+                                      (list (basename (derivation-file-name drv))
+                                            (basename txt))))))))))))
+
+(test-assert "reference DAG"
+  (let-values (((backend nodes+edges) (make-recording-backend)))
+    (run-with-store %store
+      (mlet* %store-monad ((txt   (text-file "text-file" "Hello!"))
+                           (guile (package->derivation %bootstrap-guile))
+                           (drv   (gexp->derivation "output"
+                                                    #~(symlink #$txt #$output)
+                                                    #:guile-for-build
+                                                    guile))
+                           (out -> (derivation->output-path drv)))
+        ;; We should see only OUT and TXT, with an edge from the former to the
+        ;; latter.
+        (mbegin %store-monad
+          (built-derivations (list drv))
+          (export-graph (list (derivation->output-path drv)) 'port
+                        #:node-type %reference-node-type
+                        #:backend backend)
+          (let-values (((nodes edges) (nodes+edges)))
+            (return
+             (and (equal? (match nodes
+                            (((ids labels) ...)
+                             ids))
+                          (list out txt))
+                  (equal? edges `((,out ,txt)))))))))))
+
+(test-end "graph")
+
+
+(exit (= (test-runner-fail-count (test-runner-current)) 0))