diff options
Diffstat (limited to 'guix/scripts/graph.scm')
| -rw-r--r-- | guix/scripts/graph.scm | 82 |
1 files changed, 62 insertions, 20 deletions
diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index ba63780e2b..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) @@ -356,15 +395,18 @@ Emit a Graphviz (dot) representation of the dependencies of PACKAGE...\n")) (_ #f)) opts))) (with-store store - (run-with-store store - ;; XXX: Since grafting can trigger unsolicited builds, disable it. - (mlet %store-monad ((_ (set-grafting #f)) - (nodes (mapm %store-monad - (node-type-convert type) - packages))) - (export-graph (concatenate nodes) - (current-output-port) - #:node-type type)))))) + ;; Ask for absolute file names so that .drv file names passed from the + ;; user to 'read-derivation' are absolute when it returns. + (with-fluids ((%file-port-name-canonicalization 'absolute)) + (run-with-store store + ;; XXX: Since grafting can trigger unsolicited builds, disable it. + (mlet %store-monad ((_ (set-grafting #f)) + (nodes (mapm %store-monad + (node-type-convert type) + items))) + (export-graph (concatenate nodes) + (current-output-port) + #:node-type type))))))) #t) ;;; graph.scm ends here |