diff options
| -rw-r--r-- | guix/profiles.scm | 73 | ||||
| -rw-r--r-- | tests/profiles.scm | 36 |
2 files changed, 89 insertions, 20 deletions
diff --git a/guix/profiles.scm b/guix/profiles.scm index 6733f105e3..a66add3e07 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -154,7 +154,7 @@ (output manifest-entry-output ; string (default "out")) (item manifest-entry-item) ; package | store path - (dependencies manifest-entry-dependencies ; (store path | package)* + (dependencies manifest-entry-dependencies ; <manifest-entry>* (default '())) (search-paths manifest-entry-search-paths ; search-path-specification* (default '()))) @@ -179,10 +179,10 @@ "Return a manifest entry for the OUTPUT of package PACKAGE." (let ((deps (map (match-lambda ((label package) - (gexp-input package)) + (package->manifest-entry package)) ((label package output) - (gexp-input package output))) - (package-transitive-propagated-inputs package)))) + (package->manifest-entry package output))) + (package-propagated-inputs package)))) (manifest-entry (name (package-name package)) (version (package-version package)) @@ -210,20 +210,20 @@ denoting a specific output of a package." (($ <manifest-entry> name version output (? string? path) (deps ...) (search-paths ...)) #~(#$name #$version #$output #$path - (propagated-inputs #$deps) + (propagated-inputs #$(map entry->gexp deps)) (search-paths #$(map search-path-specification->sexp search-paths)))) (($ <manifest-entry> name version output (? package? package) (deps ...) (search-paths ...)) #~(#$name #$version #$output (ungexp package (or output "out")) - (propagated-inputs #$deps) + (propagated-inputs #$(map entry->gexp deps)) (search-paths #$(map search-path-specification->sexp search-paths)))))) (match manifest (($ <manifest> (entries ...)) - #~(manifest (version 2) + #~(manifest (version 3) (packages #$(map entry->gexp entries)))))) (define (find-package name version) @@ -254,17 +254,27 @@ procedure is here for backward-compatibility and will eventually vanish." (package-native-search-paths package) '()))) + (define (infer-dependency item) + ;; Return a <manifest-entry> for ITEM. + (let-values (((name version) + (package-name->name+version + (store-path-package-name item)))) + (manifest-entry + (name name) + (version version) + (item item)))) + (match sexp (('manifest ('version 0) ('packages ((name version output path) ...))) (manifest (map (lambda (name version output path) (manifest-entry - (name name) - (version version) - (output output) - (item path) - (search-paths (infer-search-paths name version)))) + (name name) + (version version) + (output output) + (item path) + (search-paths (infer-search-paths name version)))) name version output path))) ;; Version 1 adds a list of propagated inputs to the @@ -286,7 +296,7 @@ procedure is here for backward-compatibility and will eventually vanish." (version version) (output output) (item path) - (dependencies deps) + (dependencies (map infer-dependency deps)) (search-paths (infer-search-paths name version))))) name version output path deps))) @@ -304,10 +314,30 @@ procedure is here for backward-compatibility and will eventually vanish." (version version) (output output) (item path) - (dependencies deps) + (dependencies (map infer-dependency deps)) (search-paths (map sexp->search-path-specification search-paths)))) 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)))) (_ (raise (condition (&message (message "unsupported manifest format"))))))) @@ -471,12 +501,15 @@ replace it." (define (manifest-inputs manifest) "Return a list of <gexp-input> objects for MANIFEST." - (append-map (match-lambda - (($ <manifest-entry> name version output thing deps) - ;; THING may be a package or a file name. In the latter case, - ;; assume it's already valid. Ditto for DEPS. - (cons (gexp-input thing output) deps))) - (manifest-entries manifest))) + (define entry->input + (match-lambda + (($ <manifest-entry> name version output thing deps) + ;; THING may be a package or a file name. In the latter case, assume + ;; it's already valid. + (cons (gexp-input thing output) + (append-map entry->input deps))))) + + (append-map entry->input (manifest-entries manifest))) (define* (manifest-lookup-package manifest name #:optional version) "Return as a monadic value the first package or store path referenced by diff --git a/tests/profiles.scm b/tests/profiles.scm index 093422792f..e8b1bb832c 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -288,6 +288,42 @@ (manifest-entry-search-paths (package->manifest-entry mpl))))) +(test-equal "packages->manifest, propagated inputs" + (map (match-lambda + ((label package) + (list (package-name package) (package-version package) + package))) + (package-propagated-inputs packages:guile-2.2)) + (map (lambda (entry) + (list (manifest-entry-name entry) + (manifest-entry-version entry) + (manifest-entry-item entry))) + (manifest-entry-dependencies + (package->manifest-entry packages:guile-2.2)))) + +(test-assertm "read-manifest" + (mlet* %store-monad ((manifest -> (packages->manifest + (list (package + (inherit %bootstrap-guile) + (native-search-paths + (package-native-search-paths + packages:guile-2.0)))))) + (drv (profile-derivation manifest + #:hooks '() + #:locales? #f)) + (out -> (derivation->output-path drv))) + (define (entry->sexp entry) + (list (manifest-entry-name entry) + (manifest-entry-version entry) + (manifest-entry-search-paths entry) + (manifest-entry-dependencies entry))) + + (mbegin %store-monad + (built-derivations (list drv)) + (let ((manifest2 (profile-manifest out))) + (return (equal? (map entry->sexp (manifest-entries manifest)) + (map entry->sexp (manifest-entries manifest2)))))))) + (test-assertm "etc/profile" ;; Make sure we get an 'etc/profile' file that at least defines $PATH. (mlet* %store-monad |