From a773c3142dd168e1c4480614d3f5fd9d003954cd Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Fri, 20 May 2016 17:07:23 +0200
Subject: 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.
---
 guix/scripts/graph.scm | 63 ++++++++++++++++++++++++++++++++++++++++----------
 1 file changed, 51 insertions(+), 12 deletions(-)

(limited to 'guix/scripts')

diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm
index 1623421196..782fca5d63 100644
--- a/guix/scripts/graph.scm
+++ b/guix/scripts/graph.scm
@@ -33,6 +33,7 @@ (define-module (guix scripts graph)
   #: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 @@ (define (package-node-edges package)
      ;; 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 @@ (define %bag-node-type
   (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 @@ (define %bag-with-origins-node-type
   (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 @@ (define %bag-emerged-node-type
   (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 @@ (define %derivation-node-type
   (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 @@ (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))))))
+   (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 @@ (define (guix-graph . args)
                                    (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 @@ (define (guix-graph . args)
             (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)))))))
-- 
cgit v1.2.3