[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
02/02: graph: Add '%bag-with-origins-node-type'.
|
From: |
Ludovic Courtès |
|
Subject: |
02/02: graph: Add '%bag-with-origins-node-type'. |
|
Date: |
Mon, 23 Nov 2015 22:38:30 +0000 |
civodul pushed a commit to branch master
in repository guix.
commit 38b92daa81d6c5eca77ae0cc3d454da46a64b48a
Author: Ludovic Courtès <address@hidden>
Date: Mon Nov 23 23:31:53 2015 +0100
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.
---
doc/guix.texi | 3 +++
guix/scripts/graph.scm | 48 ++++++++++++++++++++++++++++++++++++------------
tests/graph.scm | 26 ++++++++++++++++++++++++++
tests/guix-graph.sh | 2 +-
4 files changed, 66 insertions(+), 13 deletions(-)
diff --git a/doc/guix.texi b/doc/guix.texi
index a56bda9..5eb6720 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -4631,6 +4631,9 @@ here, for conciseness.
Similar to @code{bag-emerged}, but this time including all the bootstrap
dependencies.
address@hidden bag-with-origins
+Similar to @code{bag}, but also showing origins and their dependencies.
+
@item derivations
This is the most detailed representation: It shows the DAG of
derivations (@pxref{Derivations}) and plain store items. Compared to
diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm
index f607ebe..9255f00 100644
--- a/guix/scripts/graph.scm
+++ b/guix/scripts/graph.scm
@@ -30,11 +30,13 @@
#:use-module (gnu packages)
#:use-module (guix sets)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-37)
#:use-module (ice-9 match)
#:export (%package-node-type
%bag-node-type
+ %bag-with-origins-node-type
%bag-emerged-node-type
%derivation-node-type
%reference-node-type
@@ -104,17 +106,23 @@ file name."
low))))))
(define (bag-node-edges thing)
- "Return the list of dependencies of THING, a package or origin, etc."
- (if (package? thing)
- (match (bag-direct-inputs (package->bag thing))
- (((labels things . outputs) ...)
- (filter-map (match-lambda
- ((? package? p) p)
- ;; XXX: Here we choose to filter out origins, files,
- ;; etc. Replace "#f" with "x" to reinstate them.
- (x #f))
- things)))
- '()))
+ "Return the list of dependencies of THING, a package or origin.
+Dependencies may include packages, origin, and file names."
+ (cond ((package? thing)
+ (match (bag-direct-inputs (package->bag thing))
+ (((labels things . outputs) ...)
+ things)))
+ ((origin? thing)
+ (cons (origin-patch-guile thing)
+ (if (or (pair? (origin-patches thing))
+ (origin-snippet thing))
+ (match (origin-patch-inputs thing)
+ (#f '())
+ (((labels dependencies _ ...) ...)
+ (delete-duplicates dependencies eq?)))
+ '())))
+ (else
+ '())))
(define %bag-node-type
;; Type for the traversal of package nodes via the "bag" representation,
@@ -124,7 +132,22 @@ file name."
(description "the DAG of packages, including implicit inputs")
(identifier bag-node-identifier)
(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
(memoize
@@ -239,6 +262,7 @@ substitutes."
;; List of all the node types.
(list %package-node-type
%bag-node-type
+ %bag-with-origins-node-type
%bag-emerged-node-type
%derivation-node-type
%reference-node-type))
diff --git a/tests/graph.scm b/tests/graph.scm
index 9c9e366..ad8aea0 100644
--- a/tests/graph.scm
+++ b/tests/graph.scm
@@ -134,6 +134,32 @@ edges."
(((labels 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"
(let-values (((backend nodes+edges) (make-recording-backend)))
(run-with-store %store
diff --git a/tests/guix-graph.sh b/tests/guix-graph.sh
index e0cbebb..4d5a755 100644
--- a/tests/guix-graph.sh
+++ b/tests/guix-graph.sh
@@ -24,7 +24,7 @@ guix graph --version
for package in guile-bootstrap coreutils python
do
- for graph in package bag-emerged bag
+ for graph in package bag-emerged bag bag-with-origins
do
guix graph -t "$graph" "$package" | grep "$package"
done