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, 426 insertions, 0 deletions

diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm
new file mode 100644
index 0000000000..475f054571
--- /dev/null
+++ b/guix/scripts/graph.scm
@@ -0,0 +1,426 @@
+;;; 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 (guix scripts graph)
+  #:use-module (guix ui)
+  #:use-module (guix utils)
+  #:use-module (guix packages)
+  #:use-module (guix monads)
+  #:use-module (guix store)
+  #:use-module (guix gexp)
+  #:use-module (guix derivations)
+  #:use-module ((guix build-system gnu) #:select (standard-packages))
+  #:use-module (gnu packages)
+  #:use-module (guix sets)
+  #:use-module (guix records)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-37)
+  #:use-module (ice-9 match)
+  #:use-module (web uri)
+  #:export (%package-node-type
+            %bag-node-type
+            %bag-emerged-node-type
+            %derivation-node-type
+            %reference-node-type
+
+            %graphviz-backend
+            graph-backend?
+            graph-backend
+
+            export-graph
+
+            guix-graph))
+
+
+;;;
+;;; Node types.
+;;;
+
+(define-record-type* <node-type> node-type make-node-type
+  node-type?
+  (identifier  node-type-identifier)              ;node -> M identifier
+  (label       node-type-label)                   ;node -> string
+  (edges       node-type-edges)                   ;node -> M list of nodes
+  (convert     node-type-convert                  ;package -> M list of nodes
+               (default (lift1 list %store-monad)))
+  (name        node-type-name)                    ;string
+  (description node-type-description))            ;string
+
+
+;;;
+;;; Package DAG.
+;;;
+
+(define (uri->file-name uri)
+  "Return the 'base name' of URI or URI itself, where URI is a string."
+  (let ((path (and=> (string->uri uri) uri-path)))
+    (if path
+        (basename path)
+        uri)))
+
+(define (node-full-name thing)
+  "Return a human-readable name to denote THING, a package, origin, or file
+name."
+  (cond ((package? thing)
+         (package-full-name thing))
+        ((origin? thing)
+         (or (origin-file-name thing)
+             (match (origin-uri thing)
+               ((head . tail)
+                (uri->file-name head))
+               ((? string? uri)
+                (uri->file-name uri)))))
+        ((string? thing)                          ;file name
+         (or (basename thing)
+             (error "basename" thing)))
+        (else
+         (number->string (object-address thing) 16))))
+
+(define (package-node-edges package)
+  "Return the list of dependencies of PACKAGE."
+  (match (package-direct-inputs package)
+    (((labels packages . outputs) ...)
+     ;; Filter out origins and other non-package dependencies.
+     (filter package? packages))))
+
+(define %package-node-type
+  ;; Type for the traversal of package nodes.
+  (node-type
+   (name "package")
+   (description "the DAG of packages, excluding implicit inputs")
+
+   ;; We use package addresses as unique identifiers.  This generally works
+   ;; well, but for generated package objects, we could end up with two
+   ;; packages that are not 'eq?', yet map to the same derivation (XXX).
+   (identifier (lift1 object-address %store-monad))
+   (label node-full-name)
+   (edges (lift1 package-node-edges %store-monad))))
+
+
+;;;
+;;; Package DAG using bags.
+;;;
+
+(define (bag-node-identifier thing)
+  "Return a unique identifier for THING, which may be a package, origin, or a
+file name."
+  ;; If THING is a file name (a string), we just return it; if it's a package
+  ;; or origin, we return its address.  That gives us the object graph, but
+  ;; that may differ from the derivation graph (for instance,
+  ;; 'package-with-bootstrap-guile' generates fresh package objects, and
+  ;; several packages that are not 'eq?' may actually map to the same
+  ;; derivation.)  Thus, we lower THING and use its derivation file name as a
+  ;; unique identifier.
+  (with-monad %store-monad
+    (if (string? thing)
+        (return thing)
+        (mlet %store-monad ((low (lower-object thing)))
+          (return (if (derivation? low)
+                      (derivation-file-name low)
+                      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)))
+      '()))
+
+(define %bag-node-type
+  ;; Type for the traversal of package nodes via the "bag" representation,
+  ;; which includes implicit inputs.
+  (node-type
+   (name "bag")
+   (description "the DAG of packages, including implicit inputs")
+   (identifier bag-node-identifier)
+   (label node-full-name)
+   (edges (lift1 bag-node-edges %store-monad))))
+
+(define standard-package-set
+  (memoize
+   (lambda ()
+     "Return the set of standard packages provided by GNU-BUILD-SYSTEM."
+     (match (standard-packages)
+       (((labels packages . output) ...)
+        (list->setq packages))))))
+
+(define (bag-node-edges-sans-bootstrap thing)
+  "Like 'bag-node-edges', but pretend that the standard packages of
+GNU-BUILD-SYSTEM have zero dependencies."
+  (if (set-contains? (standard-package-set) thing)
+      '()
+      (bag-node-edges thing)))
+
+(define %bag-emerged-node-type
+  ;; Like %BAG-NODE-TYPE, but without the bootstrap subset of the DAG.
+  (node-type
+   (name "bag-emerged")
+   (description "same as 'bag', but without the bootstrap nodes")
+   (identifier bag-node-identifier)
+   (label node-full-name)
+   (edges (lift1 bag-node-edges-sans-bootstrap %store-monad))))
+
+
+;;;
+;;; Derivation DAG.
+;;;
+
+(define (file->derivation file)
+  "Read the derivation from FILE and return it."
+  (call-with-input-file file read-derivation))
+
+(define (derivation-dependencies obj)
+  "Return the <derivation> objects and store items corresponding to the
+dependencies of OBJ, a <derivation> or store item."
+  (if (derivation? obj)
+      (append (map (compose file->derivation derivation-input-path)
+                   (derivation-inputs obj))
+              (derivation-sources obj))
+      '()))
+
+(define (derivation-node-identifier node)
+  "Return a unique identifier for NODE, which may be either a <derivation> or
+a plain store file."
+  (if (derivation? node)
+      (derivation-file-name node)
+      node))
+
+(define (derivation-node-label node)
+  "Return a label for NODE, a <derivation> object or plain store item."
+  (store-path-package-name (match node
+                             ((? derivation? drv)
+                              (derivation-file-name drv))
+                             ((? string? file)
+                              file))))
+
+(define %derivation-node-type
+  ;; DAG of derivations.  Very accurate, very detailed, but usually too much
+  ;; detailed.
+  (node-type
+   (name "derivation")
+   (description "the DAG of derivations")
+   (convert (lambda (package)
+              (with-monad %store-monad
+                (>>= (package->derivation package)
+                     (lift1 list %store-monad)))))
+   (identifier (lift1 derivation-node-identifier %store-monad))
+   (label derivation-node-label)
+   (edges (lift1 derivation-dependencies %store-monad))))
+
+
+;;;
+;;; DAG of residual references (aka. run-time dependencies).
+;;;
+
+(define (references* item)
+  "Return as a monadic value the references of ITEM, based either on the
+information available in the local store or using information about
+substitutes."
+  (lambda (store)
+    (guard (c ((nix-protocol-error? c)
+               (match (substitutable-path-info store (list item))
+                 ((info)
+                  (values (substitutable-references info) store))
+                 (()
+                  (leave (_ "references for '~a' are not known~%")
+                         item)))))
+      (values (references store item) store))))
+
+(define %reference-node-type
+  (node-type
+   (name "references")
+   (description "the DAG of run-time dependencies (store references)")
+   (convert (lambda (package)
+              ;; Return the output file names of PACKAGE.
+              (mlet %store-monad ((drv (package->derivation package)))
+                (return (match (derivation->output-paths drv)
+                          (((_ . file-names) ...)
+                           file-names))))))
+   (identifier (lift1 identity %store-monad))
+   (label store-path-package-name)
+   (edges references*)))
+
+
+;;;
+;;; List of node types.
+;;;
+
+(define %node-types
+  ;; List of all the node types.
+  (list %package-node-type
+        %bag-node-type
+        %bag-emerged-node-type
+        %derivation-node-type
+        %reference-node-type))
+
+(define (lookup-node-type name)
+  "Return the node type called NAME.  Raise an error if it is not found."
+  (or (find (lambda (type)
+              (string=? (node-type-name type) name))
+            %node-types)
+      (leave (_ "~a: unknown node type~%") name)))
+
+(define (list-node-types)
+  "Print the available node types along with their synopsis."
+  (display (_ "The available node types are:\n"))
+  (newline)
+  (for-each (lambda (type)
+              (format #t "  - ~a: ~a~%"
+                      (node-type-name type)
+                      (node-type-description type)))
+            %node-types))
+
+
+;;;
+;;; Graphviz export.
+;;;
+
+(define-record-type <graph-backend>
+  (graph-backend prologue epilogue node edge)
+  graph-backend?
+  (prologue graph-backend-prologue)
+  (epilogue graph-backend-epilogue)
+  (node     graph-backend-node)
+  (edge     graph-backend-edge))
+
+(define (emit-prologue name port)
+  (format port "digraph \"Guix ~a\" {\n"
+          name))
+(define (emit-epilogue port)
+  (display "\n}\n" port))
+(define (emit-node id label port)
+  (format port "  \"~a\" [label = \"~a\", shape = box, fontname = Helvetica];~%"
+          id label))
+(define (emit-edge id1 id2 port)
+  (format port "  \"~a\" -> \"~a\" [color = red];~%"
+          id1 id2))
+
+(define %graphviz-backend
+  (graph-backend emit-prologue emit-epilogue
+                 emit-node emit-edge))
+
+(define* (export-graph sinks port
+                       #:key
+                       (node-type %package-node-type)
+                       (backend %graphviz-backend))
+  "Write to PORT the representation of the DAG with the given SINKS, using the
+given BACKEND.  Use NODE-TYPE to traverse the DAG."
+  (match backend
+    (($ <graph-backend> emit-prologue emit-epilogue emit-node emit-edge)
+     (emit-prologue (node-type-name node-type) port)
+
+     (match node-type
+       (($ <node-type> node-identifier node-label node-edges)
+        (let loop ((nodes   sinks)
+                   (visited (set)))
+          (match nodes
+            (()
+             (with-monad %store-monad
+               (emit-epilogue port)
+               (store-return #t)))
+            ((head . tail)
+             (mlet %store-monad ((id (node-identifier head)))
+               (if (set-contains? visited id)
+                   (loop tail visited)
+                   (mlet* %store-monad ((dependencies (node-edges head))
+                                        (ids          (mapm %store-monad
+                                                            node-identifier
+                                                            dependencies)))
+                     (emit-node id (node-label head) port)
+                     (for-each (lambda (dependency dependency-id)
+                                 (emit-edge id dependency-id port))
+                               dependencies ids)
+                     (loop (append dependencies tail)
+                           (set-insert id visited)))))))))))))
+
+
+;;;
+;;; Command-line options.
+;;;
+
+(define %options
+  (list (option '(#\t "type") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'node-type (lookup-node-type arg)
+                              result)))
+        (option '("list-types") #f #f
+                (lambda (opt name arg result)
+                  (list-node-types)
+                  (exit 0)))
+        (option '(#\h "help") #f #f
+                (lambda args
+                  (show-help)
+                  (exit 0)))
+        (option '(#\V "version") #f #f
+                (lambda args
+                  (show-version-and-exit "guix edit")))))
+
+(define (show-help)
+  ;; TRANSLATORS: Here 'dot' is the name of a program; it must not be
+  ;; translated.
+  (display (_ "Usage: guix graph PACKAGE...
+Emit a Graphviz (dot) representation of the dependencies of PACKAGE...\n"))
+  (display (_ "
+  -t, --type=TYPE        represent nodes of the given TYPE"))
+  (display (_ "
+      --list-types       list the available graph types"))
+  (newline)
+  (display (_ "
+  -h, --help             display this help and exit"))
+  (display (_ "
+  -V, --version          display version information and exit"))
+  (newline)
+  (show-bug-report-information))
+
+(define %default-options
+  `((node-type . ,%package-node-type)))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-graph . args)
+  (with-error-handling
+    (let* ((opts     (parse-command-line args %options
+                                         (list %default-options)))
+           (specs    (filter-map (match-lambda
+                                   (('argument . spec) spec)
+                                   (_ #f))
+                                 opts))
+           (type     (assoc-ref opts 'node-type))
+           (packages (map specification->package specs)))
+      (with-store store
+        (run-with-store store
+          (mlet %store-monad ((nodes (mapm %store-monad
+                                           (node-type-convert type)
+                                           packages)))
+            (export-graph (concatenate nodes)
+                          (current-output-port)
+                          #:node-type type))))))
+  #t)
+
+;;; graph.scm ends here