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.
This commit is contained in:
Ludovic Courtès 2017-06-06 15:29:50 +02:00
parent 55b4715fd4
commit b3a00885c0
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 83 additions and 49 deletions

View File

@ -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")))))))

View File

@ -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))