aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2017-06-06 15:29:50 +0200
committerLudovic Courtès <ludo@gnu.org>2017-06-21 11:05:52 +0200
commitb3a00885c0a420692ccc4c227252bb44619399d5 (patch)
tree3fcb8997ed451e5f8bc01d490db7b3da2e2e096a
parent55b4715fd4c03e46501f123c5c9bc6072edf12a4 (diff)
downloadguix-b3a00885c0a420692ccc4c227252bb44619399d5.tar
guix-b3a00885c0a420692ccc4c227252bb44619399d5.tar.gz
profiles: Manifest entries keep a reference to their parent entry.
* guix/profiles.scm (<manifest-entry>)[parent]: New field. (package->manifest-entry): Add #:parent parameter. Fill out the 'parent' field of <manifest-entry>; pass #:parent in recursive calls. * guix/profiles.scm (sexp->manifest)[sexp->manifest-entry]: New procedure. Use it for version 3. * tests/profiles.scm ("manifest-entry-parent"): New procedure. ("read-manifest")[entry->sexp]: Add 'manifest-entry-parent' to the result.
-rw-r--r--guix/profiles.scm120
-rw-r--r--tests/profiles.scm12
2 files changed, 83 insertions, 49 deletions
diff --git a/guix/profiles.scm b/guix/profiles.scm
index a66add3e07..c85d7ef5cb 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -68,6 +68,7 @@
manifest-entry-item
manifest-entry-dependencies
manifest-entry-search-paths
+ manifest-entry-parent
manifest-pattern
manifest-pattern?
@@ -157,7 +158,9 @@
(dependencies manifest-entry-dependencies ; <manifest-entry>*
(default '()))
(search-paths manifest-entry-search-paths ; search-path-specification*
- (default '())))
+ (default '()))
+ (parent manifest-entry-parent ; promise (#f | <manifest-entry>)
+ (default (delay #f))))
(define-record-type* <manifest-pattern> manifest-pattern
make-manifest-pattern
@@ -175,21 +178,28 @@
(call-with-input-file file read-manifest)
(manifest '()))))
-(define* (package->manifest-entry package #:optional (output "out"))
+(define* (package->manifest-entry package #:optional (output "out")
+ #:key (parent (delay #f)))
"Return a manifest entry for the OUTPUT of package PACKAGE."
- (let ((deps (map (match-lambda
- ((label package)
- (package->manifest-entry package))
- ((label package output)
- (package->manifest-entry package output)))
- (package-propagated-inputs package))))
- (manifest-entry
- (name (package-name package))
- (version (package-version package))
- (output output)
- (item package)
- (dependencies (delete-duplicates deps))
- (search-paths (package-transitive-native-search-paths package)))))
+ ;; For each dependency, keep a promise pointing to its "parent" entry.
+ (letrec* ((deps (map (match-lambda
+ ((label package)
+ (package->manifest-entry package
+ #:parent (delay entry)))
+ ((label package output)
+ (package->manifest-entry package output
+ #:parent (delay entry))))
+ (package-propagated-inputs package)))
+ (entry (manifest-entry
+ (name (package-name package))
+ (version (package-version package))
+ (output output)
+ (item package)
+ (dependencies (delete-duplicates deps))
+ (search-paths
+ (package-transitive-native-search-paths package))
+ (parent parent))))
+ entry))
(define (packages->manifest packages)
"Return a list of manifest entries, one for each item listed in PACKAGES.
@@ -254,7 +264,7 @@ procedure is here for backward-compatibility and will eventually vanish."
(package-native-search-paths package)
'())))
- (define (infer-dependency item)
+ (define (infer-dependency item parent)
;; Return a <manifest-entry> for ITEM.
(let-values (((name version)
(package-name->name+version
@@ -262,7 +272,28 @@ procedure is here for backward-compatibility and will eventually vanish."
(manifest-entry
(name name)
(version version)
- (item item))))
+ (item item)
+ (parent parent))))
+
+ (define* (sexp->manifest-entry sexp #:optional (parent (delay #f)))
+ (match sexp
+ ((name version output path
+ ('propagated-inputs deps)
+ ('search-paths search-paths)
+ extra-stuff ...)
+ ;; For each of DEPS, keep a promise pointing to ENTRY.
+ (letrec* ((deps* (map (cut sexp->manifest-entry <> (delay entry))
+ deps))
+ (entry (manifest-entry
+ (name name)
+ (version version)
+ (output output)
+ (item path)
+ (dependencies deps*)
+ (search-paths (map sexp->search-path-specification
+ search-paths))
+ (parent parent))))
+ entry))))
(match sexp
(('manifest ('version 0)
@@ -291,13 +322,17 @@ procedure is here for backward-compatibility and will eventually vanish."
directories)
((directories ...)
directories))))
- (manifest-entry
- (name name)
- (version version)
- (output output)
- (item path)
- (dependencies (map infer-dependency deps))
- (search-paths (infer-search-paths name version)))))
+ (letrec* ((deps* (map (cute infer-dependency <> (delay entry))
+ deps))
+ (entry (manifest-entry
+ (name name)
+ (version version)
+ (output output)
+ (item path)
+ (dependencies deps*)
+ (search-paths
+ (infer-search-paths name version)))))
+ entry)))
name version output path deps)))
;; Version 2 adds search paths and is slightly more verbose.
@@ -309,35 +344,24 @@ procedure is here for backward-compatibility and will eventually vanish."
...)))
(manifest
(map (lambda (name version output path deps search-paths)
- (manifest-entry
- (name name)
- (version version)
- (output output)
- (item path)
- (dependencies (map infer-dependency deps))
- (search-paths (map sexp->search-path-specification
- search-paths))))
+ (letrec* ((deps* (map (cute infer-dependency <> (delay entry))
+ deps))
+ (entry (manifest-entry
+ (name name)
+ (version version)
+ (output output)
+ (item path)
+ (dependencies deps*)
+ (search-paths
+ (map sexp->search-path-specification
+ search-paths)))))
+ entry))
name version output path deps search-paths)))
;; Version 3 represents DEPS as full-blown manifest entries.
(('manifest ('version 3 minor-version ...)
('packages (entries ...)))
- (letrec ((sexp->manifest-entry
- (match-lambda
- ((name version output path
- ('propagated-inputs deps)
- ('search-paths search-paths)
- extra-stuff ...)
- (manifest-entry
- (name name)
- (version version)
- (output output)
- (item path)
- (dependencies (map sexp->manifest-entry deps))
- (search-paths (map sexp->search-path-specification
- search-paths)))))))
-
- (manifest (map sexp->manifest-entry entries))))
+ (manifest (map sexp->manifest-entry entries)))
(_
(raise (condition
(&message (message "unsupported manifest format")))))))
diff --git a/tests/profiles.scm b/tests/profiles.scm
index e8b1bb832c..94759c05ef 100644
--- a/tests/profiles.scm
+++ b/tests/profiles.scm
@@ -301,6 +301,15 @@
(manifest-entry-dependencies
(package->manifest-entry packages:guile-2.2))))
+(test-assert "manifest-entry-parent"
+ (let ((entry (package->manifest-entry packages:guile-2.2)))
+ (match (manifest-entry-dependencies entry)
+ ((dependencies ..1)
+ (and (every (lambda (parent)
+ (eq? entry (force parent)))
+ (map manifest-entry-parent dependencies))
+ (not (force (manifest-entry-parent entry))))))))
+
(test-assertm "read-manifest"
(mlet* %store-monad ((manifest -> (packages->manifest
(list (package
@@ -316,7 +325,8 @@
(list (manifest-entry-name entry)
(manifest-entry-version entry)
(manifest-entry-search-paths entry)
- (manifest-entry-dependencies entry)))
+ (manifest-entry-dependencies entry)
+ (force (manifest-entry-parent entry))))
(mbegin %store-monad
(built-derivations (list drv))