03/06: graph: Allow store file names for 'derivation' and 'references' graphs.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit a773c3142dd168e1c4480614d3f5fd9d003954cd
Author: Ludovic Courtès <address@hidden>
Date:   Fri May 20 17:07:23 2016 +0200

    graph: Allow store file names for 'derivation' and 'references' graphs.
    
    * guix/scripts/graph.scm (%derivation-node-type)[convert]: Add
    'derivation-path?' and catch-all clauses.
    (%reference-node-type)[convert]: Add 'store-path?' and catch-all
    clauses.
    (assert-package, nodes-from-package): New procedures.
    (%package-node-type, %bag-node-type,%bag-with-origins-node-type)
    (%bag-emerged-node-type): Add 'convert' field
    (guix-graph): Rename 'packages' to 'items' and
    allow 'store-path?' arguments.
    * guix/graph.scm (<node-type>)[convert]: Adjust comment.
    * doc/guix.texi (Invoking guix graph): Document it.
---
 doc/guix.texi          |   14 +++++++++++
 guix/graph.scm         |    2 +-
 guix/scripts/graph.scm |   63 +++++++++++++++++++++++++++++++++++++++---------
 tests/guix-graph.sh    |   18 +++++++++++++-
 4 files changed, 83 insertions(+), 14 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 3f0106b..d88cc25 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -5161,6 +5161,12 @@ derivations (@pxref{Derivations}) and plain store items. 
 Compared to
 the above representation, many additional nodes are visible, including
 build scripts, patches, Guile modules, etc.
 
+For this type of graph, it is also possible to pass a @file{.drv} file
+name instead of a package name, as in:
+
address@hidden
+guix graph -t derivation `guix system build -d my-config.scm`
address@hidden example
 @end table
 
 All the types above correspond to @emph{build-time dependencies}.  The
@@ -5173,6 +5179,14 @@ by @command{guix gc --references} (@pxref{Invoking guix 
gc}).
 
 If the given package output is not available in the store, @command{guix
 graph} attempts to obtain dependency information from substitutes.
+
+Here you can also pass a store file name instead of a package name.  For
+example, the command below produces the reference graph of your profile
+(which can be big!):
+
address@hidden
+guix graph -t references `readlink -f ~/.guix-profile`
address@hidden example
 @end table
 
 The available options are the following:
diff --git a/guix/graph.scm b/guix/graph.scm
index 1a8f2d5..ad93403 100644
--- a/guix/graph.scm
+++ b/guix/graph.scm
@@ -65,7 +65,7 @@
   (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
+  (convert     node-type-convert                  ;any -> M list of nodes
                (default (lift1 list %store-monad)))
   (name        node-type-name)                    ;string
   (description node-type-description))            ;string
diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm
index 1623421..782fca5 100644
--- a/guix/scripts/graph.scm
+++ b/guix/scripts/graph.scm
@@ -33,6 +33,7 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-37)
   #:use-module (ice-9 match)
   #:export (%package-node-type
@@ -70,11 +71,27 @@ name."
      ;; Filter out origins and other non-package dependencies.
      (filter package? packages))))
 
+(define assert-package
+  (match-lambda
+    ((? package? package)
+     package)
+    (x
+     (raise
+      (condition
+       (&message
+        (message (format #f (_ "~a: invalid argument (package name expected)")
+                         x))))))))
+
+(define nodes-from-package
+  ;; The default conversion method.
+  (lift1 (compose list assert-package) %store-monad))
+
 (define %package-node-type
   ;; Type for the traversal of package nodes.
   (node-type
    (name "package")
    (description "the DAG of packages, excluding implicit inputs")
+   (convert nodes-from-package)
 
    ;; We use package addresses as unique identifiers.  This generally works
    ;; well, but for generated package objects, we could end up with two
@@ -131,6 +148,7 @@ Dependencies may include packages, origin, and file names."
   (node-type
    (name "bag")
    (description "the DAG of packages, including implicit inputs")
+   (convert nodes-from-package)
    (identifier bag-node-identifier)
    (label node-full-name)
    (edges (lift1 (compose (cut filter package? <>) bag-node-edges)
@@ -140,6 +158,7 @@ Dependencies may include packages, origin, and file names."
   (node-type
    (name "bag-with-origins")
    (description "the DAG of packages and origins, including implicit inputs")
+   (convert nodes-from-package)
    (identifier bag-node-identifier)
    (label node-full-name)
    (edges (lift1 (lambda (thing)
@@ -170,6 +189,7 @@ GNU-BUILD-SYSTEM have zero dependencies."
   (node-type
    (name "bag-emerged")
    (description "same as 'bag', but without the bootstrap nodes")
+   (convert nodes-from-package)
    (identifier bag-node-identifier)
    (label node-full-name)
    (edges (lift1 (compose (cut filter package? <>)
@@ -215,10 +235,19 @@ a plain store file."
   (node-type
    (name "derivation")
    (description "the DAG of derivations")
-   (convert (lambda (package)
-              (with-monad %store-monad
-                (>>= (package->derivation package)
-                     (lift1 list %store-monad)))))
+   (convert (match-lambda
+              ((? package? package)
+               (with-monad %store-monad
+                 (>>= (package->derivation package)
+                      (lift1 list %store-monad))))
+              ((? derivation-path? item)
+               (mbegin %store-monad
+                 ((store-lift add-temp-root) item)
+                 (return (list (file->derivation item)))))
+              (x
+               (raise
+                (condition (&message (message "unsupported argument for \
+derivation graph")))))))
    (identifier (lift1 derivation-node-identifier %store-monad))
    (label derivation-node-label)
    (edges (lift1 derivation-dependencies %store-monad))))
@@ -246,12 +275,20 @@ substitutes."
   (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))))))
+   (convert (match-lambda
+              ((? package? 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)))))
+              ((? store-path? item)
+               (with-monad %store-monad
+                 (return (list item))))
+              (x
+               (raise
+                (condition (&message (message "unsupported argument for \
+reference graph")))))))
    (identifier (lift1 identity %store-monad))
    (label store-path-package-name)
    (edges references*)))
@@ -348,7 +385,9 @@ Emit a Graphviz (dot) representation of the dependencies of 
PACKAGE...\n"))
                                    (alist-cons 'argument arg result))
                                  %default-options))
            (type     (assoc-ref opts 'node-type))
-           (packages (filter-map (match-lambda
+           (items    (filter-map (match-lambda
+                                   (('argument . (? store-path? item))
+                                    item)
                                    (('argument . spec)
                                     (specification->package spec))
                                    (('expression . exp)
@@ -364,7 +403,7 @@ Emit a Graphviz (dot) representation of the dependencies of 
PACKAGE...\n"))
             (mlet %store-monad ((_     (set-grafting #f))
                                 (nodes (mapm %store-monad
                                              (node-type-convert type)
-                                             packages)))
+                                             items)))
               (export-graph (concatenate nodes)
                             (current-output-port)
                             #:node-type type)))))))
diff --git a/tests/guix-graph.sh b/tests/guix-graph.sh
index 4d5a755..1ec9970 100644
--- a/tests/guix-graph.sh
+++ b/tests/guix-graph.sh
@@ -1,5 +1,5 @@
 # GNU Guix --- Functional package management for GNU
-# Copyright © 2015 Ludovic Courtès <address@hidden>
+# Copyright © 2015, 2016 Ludovic Courtès <address@hidden>
 #
 # This file is part of GNU Guix.
 #
@@ -20,6 +20,10 @@
 # Test the 'guix graph' command-line utility.
 #
 
+tmpfile1="t-guix-graph1-$$"
+tmpfile2="t-guix-graph2-$$"
+trap 'rm -f "$tmpfile1" "$tmpfile2"' EXIT
+
 guix graph --version
 
 for package in guile-bootstrap coreutils python
@@ -37,3 +41,15 @@ guix graph -e '(@ (gnu packages bootstrap) 
%bootstrap-guile)' \
     | grep guile-bootstrap
 
 if guix graph -e +; then false; else true; fi
+
+# Try passing store file names.
+
+guix graph -t references guile-bootstrap > "$tmpfile1"
+guix graph -t references `guix build guile-bootstrap` > "$tmpfile2"
+cmp "$tmpfile1" "$tmpfile2"
+
+# XXX: Filter the file names in the graph to work around the fact that we get
+# a mixture of relative and absolute file names.
+guix graph -t derivation coreutils > "$tmpfile1"
+guix graph -t derivation `guix build -d coreutils` > "$tmpfile2"
+cmp "$tmpfile1" "$tmpfile2"