mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-25 05:48:07 -05:00
graph: Add '%bag-with-origins-node-type'.
* guix/scripts/graph.scm (bag-node-edges): Remove 'filter' call. Add case for 'origin'. (%bag-node-type)[edges]: Add filtering here. (%bag-with-origins-node-type): New variable. (%node-types): Add it. * tests/graph.scm ("bag DAG, including origins"): New test. * tests/guix-graph.sh: Add 'bag-with-origins'. * doc/guix.texi (Invoking guix graph): Document it.
This commit is contained in:
parent
961d0d2d22
commit
38b92daa81
4 changed files with 66 additions and 13 deletions
|
@ -4631,6 +4631,9 @@ here, for conciseness.
|
||||||
Similar to @code{bag-emerged}, but this time including all the bootstrap
|
Similar to @code{bag-emerged}, but this time including all the bootstrap
|
||||||
dependencies.
|
dependencies.
|
||||||
|
|
||||||
|
@item bag-with-origins
|
||||||
|
Similar to @code{bag}, but also showing origins and their dependencies.
|
||||||
|
|
||||||
@item derivations
|
@item derivations
|
||||||
This is the most detailed representation: It shows the DAG of
|
This is the most detailed representation: It shows the DAG of
|
||||||
derivations (@pxref{Derivations}) and plain store items. Compared to
|
derivations (@pxref{Derivations}) and plain store items. Compared to
|
||||||
|
|
|
@ -30,11 +30,13 @@ (define-module (guix scripts graph)
|
||||||
#:use-module (gnu packages)
|
#:use-module (gnu packages)
|
||||||
#:use-module (guix sets)
|
#:use-module (guix sets)
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1)
|
||||||
|
#:use-module (srfi srfi-26)
|
||||||
#:use-module (srfi srfi-34)
|
#:use-module (srfi srfi-34)
|
||||||
#:use-module (srfi srfi-37)
|
#:use-module (srfi srfi-37)
|
||||||
#:use-module (ice-9 match)
|
#:use-module (ice-9 match)
|
||||||
#:export (%package-node-type
|
#:export (%package-node-type
|
||||||
%bag-node-type
|
%bag-node-type
|
||||||
|
%bag-with-origins-node-type
|
||||||
%bag-emerged-node-type
|
%bag-emerged-node-type
|
||||||
%derivation-node-type
|
%derivation-node-type
|
||||||
%reference-node-type
|
%reference-node-type
|
||||||
|
@ -104,17 +106,23 @@ (define (bag-node-identifier thing)
|
||||||
low))))))
|
low))))))
|
||||||
|
|
||||||
(define (bag-node-edges thing)
|
(define (bag-node-edges thing)
|
||||||
"Return the list of dependencies of THING, a package or origin, etc."
|
"Return the list of dependencies of THING, a package or origin.
|
||||||
(if (package? thing)
|
Dependencies may include packages, origin, and file names."
|
||||||
(match (bag-direct-inputs (package->bag thing))
|
(cond ((package? thing)
|
||||||
(((labels things . outputs) ...)
|
(match (bag-direct-inputs (package->bag thing))
|
||||||
(filter-map (match-lambda
|
(((labels things . outputs) ...)
|
||||||
((? package? p) p)
|
things)))
|
||||||
;; XXX: Here we choose to filter out origins, files,
|
((origin? thing)
|
||||||
;; etc. Replace "#f" with "x" to reinstate them.
|
(cons (origin-patch-guile thing)
|
||||||
(x #f))
|
(if (or (pair? (origin-patches thing))
|
||||||
things)))
|
(origin-snippet thing))
|
||||||
'()))
|
(match (origin-patch-inputs thing)
|
||||||
|
(#f '())
|
||||||
|
(((labels dependencies _ ...) ...)
|
||||||
|
(delete-duplicates dependencies eq?)))
|
||||||
|
'())))
|
||||||
|
(else
|
||||||
|
'())))
|
||||||
|
|
||||||
(define %bag-node-type
|
(define %bag-node-type
|
||||||
;; Type for the traversal of package nodes via the "bag" representation,
|
;; Type for the traversal of package nodes via the "bag" representation,
|
||||||
|
@ -124,7 +132,22 @@ (define %bag-node-type
|
||||||
(description "the DAG of packages, including implicit inputs")
|
(description "the DAG of packages, including implicit inputs")
|
||||||
(identifier bag-node-identifier)
|
(identifier bag-node-identifier)
|
||||||
(label node-full-name)
|
(label node-full-name)
|
||||||
(edges (lift1 bag-node-edges %store-monad))))
|
(edges (lift1 (compose (cut filter package? <>) bag-node-edges)
|
||||||
|
%store-monad))))
|
||||||
|
|
||||||
|
(define %bag-with-origins-node-type
|
||||||
|
(node-type
|
||||||
|
(name "bag-with-origins")
|
||||||
|
(description "the DAG of packages and origins, including implicit inputs")
|
||||||
|
(identifier bag-node-identifier)
|
||||||
|
(label node-full-name)
|
||||||
|
(edges (lift1 (lambda (thing)
|
||||||
|
(filter (match-lambda
|
||||||
|
((? package?) #t)
|
||||||
|
((? origin?) #t)
|
||||||
|
(_ #f))
|
||||||
|
(bag-node-edges thing)))
|
||||||
|
%store-monad))))
|
||||||
|
|
||||||
(define standard-package-set
|
(define standard-package-set
|
||||||
(memoize
|
(memoize
|
||||||
|
@ -239,6 +262,7 @@ (define %node-types
|
||||||
;; List of all the node types.
|
;; List of all the node types.
|
||||||
(list %package-node-type
|
(list %package-node-type
|
||||||
%bag-node-type
|
%bag-node-type
|
||||||
|
%bag-with-origins-node-type
|
||||||
%bag-emerged-node-type
|
%bag-emerged-node-type
|
||||||
%derivation-node-type
|
%derivation-node-type
|
||||||
%reference-node-type))
|
%reference-node-type))
|
||||||
|
|
|
@ -134,6 +134,32 @@ (define (edge->tuple source target)
|
||||||
(((labels packages) ...)
|
(((labels packages) ...)
|
||||||
(map package-full-name packages))))))))
|
(map package-full-name packages))))))))
|
||||||
|
|
||||||
|
(test-assert "bag DAG, including origins"
|
||||||
|
(let-values (((backend nodes+edges) (make-recording-backend)))
|
||||||
|
(let* ((m (lambda* (uri hash-type hash name #:key system)
|
||||||
|
(text-file "foo-1.2.3.tar.gz" "This is a fake!")))
|
||||||
|
(o (origin (method m) (uri "the-uri") (sha256 #vu8(0 1 2))))
|
||||||
|
(p (dummy-package "p" (source o))))
|
||||||
|
(run-with-store %store
|
||||||
|
(export-graph (list p) 'port
|
||||||
|
#:node-type %bag-with-origins-node-type
|
||||||
|
#:backend backend))
|
||||||
|
;; We should see O among the nodes, with an edge coming from P.
|
||||||
|
(let-values (((nodes edges) (nodes+edges)))
|
||||||
|
(run-with-store %store
|
||||||
|
(mlet %store-monad ((o* (lower-object o))
|
||||||
|
(p* (lower-object p)))
|
||||||
|
(return
|
||||||
|
(and (find (match-lambda
|
||||||
|
((file "the-uri") #t)
|
||||||
|
(_ #f))
|
||||||
|
nodes)
|
||||||
|
(find (match-lambda
|
||||||
|
((source target)
|
||||||
|
(and (string=? source (derivation-file-name p*))
|
||||||
|
(string=? target o*))))
|
||||||
|
edges)))))))))
|
||||||
|
|
||||||
(test-assert "derivation DAG"
|
(test-assert "derivation DAG"
|
||||||
(let-values (((backend nodes+edges) (make-recording-backend)))
|
(let-values (((backend nodes+edges) (make-recording-backend)))
|
||||||
(run-with-store %store
|
(run-with-store %store
|
||||||
|
|
|
@ -24,7 +24,7 @@ guix graph --version
|
||||||
|
|
||||||
for package in guile-bootstrap coreutils python
|
for package in guile-bootstrap coreutils python
|
||||||
do
|
do
|
||||||
for graph in package bag-emerged bag
|
for graph in package bag-emerged bag bag-with-origins
|
||||||
do
|
do
|
||||||
guix graph -t "$graph" "$package" | grep "$package"
|
guix graph -t "$graph" "$package" | grep "$package"
|
||||||
done
|
done
|
||||||
|
|
Loading…
Reference in a new issue