diff options
author | Ludovic Courtès <ludo@gnu.org> | 2016-05-20 17:07:23 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2016-05-21 01:35:14 +0200 |
commit | a773c3142dd168e1c4480614d3f5fd9d003954cd (patch) | |
tree | daf8111a6b4a105fae5d226dad7774361d12f721 /guix | |
parent | 97507ebedc8e1265c2ed354e50a218fb9ee6087b (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')
-rw-r--r-- | guix/graph.scm | 2 | ||||
-rw-r--r-- | guix/scripts/graph.scm | 63 |
2 files changed, 52 insertions, 13 deletions
diff --git a/guix/graph.scm b/guix/graph.scm index 1a8f2d55b3..ad93403a1e 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 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))))))) |