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:
parent
55b4715fd4
commit
b3a00885c0
|
@ -68,6 +68,7 @@
|
||||||
manifest-entry-item
|
manifest-entry-item
|
||||||
manifest-entry-dependencies
|
manifest-entry-dependencies
|
||||||
manifest-entry-search-paths
|
manifest-entry-search-paths
|
||||||
|
manifest-entry-parent
|
||||||
|
|
||||||
manifest-pattern
|
manifest-pattern
|
||||||
manifest-pattern?
|
manifest-pattern?
|
||||||
|
@ -157,7 +158,9 @@
|
||||||
(dependencies manifest-entry-dependencies ; <manifest-entry>*
|
(dependencies manifest-entry-dependencies ; <manifest-entry>*
|
||||||
(default '()))
|
(default '()))
|
||||||
(search-paths manifest-entry-search-paths ; search-path-specification*
|
(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
|
(define-record-type* <manifest-pattern> manifest-pattern
|
||||||
make-manifest-pattern
|
make-manifest-pattern
|
||||||
|
@ -175,21 +178,28 @@
|
||||||
(call-with-input-file file read-manifest)
|
(call-with-input-file file read-manifest)
|
||||||
(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."
|
"Return a manifest entry for the OUTPUT of package PACKAGE."
|
||||||
(let ((deps (map (match-lambda
|
;; For each dependency, keep a promise pointing to its "parent" entry.
|
||||||
((label package)
|
(letrec* ((deps (map (match-lambda
|
||||||
(package->manifest-entry package))
|
((label package)
|
||||||
((label package output)
|
(package->manifest-entry package
|
||||||
(package->manifest-entry package output)))
|
#:parent (delay entry)))
|
||||||
(package-propagated-inputs package))))
|
((label package output)
|
||||||
(manifest-entry
|
(package->manifest-entry package output
|
||||||
(name (package-name package))
|
#:parent (delay entry))))
|
||||||
(version (package-version package))
|
(package-propagated-inputs package)))
|
||||||
(output output)
|
(entry (manifest-entry
|
||||||
(item package)
|
(name (package-name package))
|
||||||
(dependencies (delete-duplicates deps))
|
(version (package-version package))
|
||||||
(search-paths (package-transitive-native-search-paths package)))))
|
(output output)
|
||||||
|
(item package)
|
||||||
|
(dependencies (delete-duplicates deps))
|
||||||
|
(search-paths
|
||||||
|
(package-transitive-native-search-paths package))
|
||||||
|
(parent parent))))
|
||||||
|
entry))
|
||||||
|
|
||||||
(define (packages->manifest packages)
|
(define (packages->manifest packages)
|
||||||
"Return a list of manifest entries, one for each item listed in 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)
|
(package-native-search-paths package)
|
||||||
'())))
|
'())))
|
||||||
|
|
||||||
(define (infer-dependency item)
|
(define (infer-dependency item parent)
|
||||||
;; Return a <manifest-entry> for ITEM.
|
;; Return a <manifest-entry> for ITEM.
|
||||||
(let-values (((name version)
|
(let-values (((name version)
|
||||||
(package-name->name+version
|
(package-name->name+version
|
||||||
|
@ -262,7 +272,28 @@ procedure is here for backward-compatibility and will eventually vanish."
|
||||||
(manifest-entry
|
(manifest-entry
|
||||||
(name name)
|
(name name)
|
||||||
(version version)
|
(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
|
(match sexp
|
||||||
(('manifest ('version 0)
|
(('manifest ('version 0)
|
||||||
|
@ -291,13 +322,17 @@ procedure is here for backward-compatibility and will eventually vanish."
|
||||||
directories)
|
directories)
|
||||||
((directories ...)
|
((directories ...)
|
||||||
directories))))
|
directories))))
|
||||||
(manifest-entry
|
(letrec* ((deps* (map (cute infer-dependency <> (delay entry))
|
||||||
(name name)
|
deps))
|
||||||
(version version)
|
(entry (manifest-entry
|
||||||
(output output)
|
(name name)
|
||||||
(item path)
|
(version version)
|
||||||
(dependencies (map infer-dependency deps))
|
(output output)
|
||||||
(search-paths (infer-search-paths name version)))))
|
(item path)
|
||||||
|
(dependencies deps*)
|
||||||
|
(search-paths
|
||||||
|
(infer-search-paths name version)))))
|
||||||
|
entry)))
|
||||||
name version output path deps)))
|
name version output path deps)))
|
||||||
|
|
||||||
;; Version 2 adds search paths and is slightly more verbose.
|
;; 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
|
(manifest
|
||||||
(map (lambda (name version output path deps search-paths)
|
(map (lambda (name version output path deps search-paths)
|
||||||
(manifest-entry
|
(letrec* ((deps* (map (cute infer-dependency <> (delay entry))
|
||||||
(name name)
|
deps))
|
||||||
(version version)
|
(entry (manifest-entry
|
||||||
(output output)
|
(name name)
|
||||||
(item path)
|
(version version)
|
||||||
(dependencies (map infer-dependency deps))
|
(output output)
|
||||||
(search-paths (map sexp->search-path-specification
|
(item path)
|
||||||
search-paths))))
|
(dependencies deps*)
|
||||||
|
(search-paths
|
||||||
|
(map sexp->search-path-specification
|
||||||
|
search-paths)))))
|
||||||
|
entry))
|
||||||
name version output path deps search-paths)))
|
name version output path deps search-paths)))
|
||||||
|
|
||||||
;; Version 3 represents DEPS as full-blown manifest entries.
|
;; Version 3 represents DEPS as full-blown manifest entries.
|
||||||
(('manifest ('version 3 minor-version ...)
|
(('manifest ('version 3 minor-version ...)
|
||||||
('packages (entries ...)))
|
('packages (entries ...)))
|
||||||
(letrec ((sexp->manifest-entry
|
(manifest (map sexp->manifest-entry entries)))
|
||||||
(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))))
|
|
||||||
(_
|
(_
|
||||||
(raise (condition
|
(raise (condition
|
||||||
(&message (message "unsupported manifest format")))))))
|
(&message (message "unsupported manifest format")))))))
|
||||||
|
|
|
@ -301,6 +301,15 @@
|
||||||
(manifest-entry-dependencies
|
(manifest-entry-dependencies
|
||||||
(package->manifest-entry packages:guile-2.2))))
|
(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"
|
(test-assertm "read-manifest"
|
||||||
(mlet* %store-monad ((manifest -> (packages->manifest
|
(mlet* %store-monad ((manifest -> (packages->manifest
|
||||||
(list (package
|
(list (package
|
||||||
|
@ -316,7 +325,8 @@
|
||||||
(list (manifest-entry-name entry)
|
(list (manifest-entry-name entry)
|
||||||
(manifest-entry-version entry)
|
(manifest-entry-version entry)
|
||||||
(manifest-entry-search-paths entry)
|
(manifest-entry-search-paths entry)
|
||||||
(manifest-entry-dependencies entry)))
|
(manifest-entry-dependencies entry)
|
||||||
|
(force (manifest-entry-parent entry))))
|
||||||
|
|
||||||
(mbegin %store-monad
|
(mbegin %store-monad
|
||||||
(built-derivations (list drv))
|
(built-derivations (list drv))
|
||||||
|
|
Loading…
Reference in New Issue