summaryrefslogtreecommitdiff
path: root/guix/scripts
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2016-05-20 17:07:23 +0200
committerLudovic Courtès <ludo@gnu.org>2016-05-21 01:35:14 +0200
commita773c3142dd168e1c4480614d3f5fd9d003954cd (patch)
treedaf8111a6b4a105fae5d226dad7774361d12f721 /guix/scripts
parent97507ebedc8e1265c2ed354e50a218fb9ee6087b (diff)
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.
Diffstat (limited to 'guix/scripts')
-rw-r--r--guix/scripts/graph.scm63
1 files changed, 51 insertions, 12 deletions
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 @@
#: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)))))))