diff options
Diffstat (limited to 'guix/profiles.scm')
-rw-r--r-- | guix/profiles.scm | 236 |
1 files changed, 142 insertions, 94 deletions
diff --git a/guix/profiles.scm b/guix/profiles.scm index d3ff8379ad..6aaaa4f6c0 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -453,63 +453,80 @@ denoting a specific output of a package." packages) manifest-entry=?))) -(define (manifest->gexp manifest) - "Return a representation of MANIFEST as a gexp." +(define %manifest-format-version + ;; The current manifest format version. + 4) + +(define* (manifest->gexp manifest #:optional + (format-version %manifest-format-version)) + "Return a representation in FORMAT-VERSION of MANIFEST as a gexp." + (define (optional name value) + (match format-version + (4 + (if (null? value) + #~() + #~((#$name #$value)))) + (3 + (match name + ('properties #~((#$name #$@value))) + (_ #~((#$name #$value))))))) + (define (entry->gexp entry) - (match entry - (($ <manifest-entry> name version output (? string? path) - (deps ...) (search-paths ...) _ (properties ...)) - #~(#$name #$version #$output #$path - (propagated-inputs #$(map entry->gexp deps)) - (search-paths #$(map search-path-specification->sexp - search-paths)) - #$@(if (null? properties) - #~() - #~((properties . #$properties))))) - (($ <manifest-entry> name version output package - (deps ...) (search-paths ...) _ (properties ...)) - #~(#$name #$version #$output - (ungexp package (or output "out")) - (propagated-inputs #$(map entry->gexp deps)) - (search-paths #$(map search-path-specification->sexp - search-paths)) - #$@(if (null? properties) - #~() - #~((properties . #$properties))))))) + ;; Maintain in state monad a vhash of visited entries, indexed by their + ;; item, usually package objects (we cannot use the entry itself as an + ;; index since identical entries are usually not 'eq?'). Use that vhash + ;; to avoid repeating duplicate entries. This is particularly useful in + ;; the presence of propagated inputs, where we could otherwise end up + ;; repeating large trees. + (mlet %state-monad ((visited (current-state))) + (if (and (= format-version 4) + (match (vhash-assq (manifest-entry-item entry) visited) + ((_ . previous-entry) + (manifest-entry=? previous-entry entry)) + (#f #f))) + (return #~(repeated #$(manifest-entry-name entry) + #$(manifest-entry-version entry) + (ungexp (manifest-entry-item entry) + (manifest-entry-output entry)))) + (mbegin %state-monad + (set-current-state (vhash-consq (manifest-entry-item entry) + entry visited)) + (mlet %state-monad ((deps (mapm %state-monad entry->gexp + (manifest-entry-dependencies entry)))) + (return + (match entry + (($ <manifest-entry> name version output (? string? path) + (_ ...) (search-paths ...) _ (properties ...)) + #~(#$name #$version #$output #$path + #$@(optional 'propagated-inputs deps) + #$@(optional 'search-paths + (map search-path-specification->sexp + search-paths)) + #$@(optional 'properties properties))) + (($ <manifest-entry> name version output package + (_deps ...) (search-paths ...) _ (properties ...)) + #~(#$name #$version #$output + (ungexp package (or output "out")) + #$@(optional 'propagated-inputs deps) + #$@(optional 'search-paths + (map search-path-specification->sexp + search-paths)) + #$@(optional 'properties properties)))))))))) + + (unless (memq format-version '(3 4)) + (raise (formatted-message + (G_ "cannot emit manifests formatted as version ~a") + format-version))) (match manifest (($ <manifest> (entries ...)) - #~(manifest (version 3) - (packages #$(map entry->gexp entries)))))) - -(define (find-package name version) - "Return a package from the distro matching NAME and possibly VERSION. This -procedure is here for backward-compatibility and will eventually vanish." - (define find-best-packages-by-name ;break abstractions - (module-ref (resolve-interface '(gnu packages)) - 'find-best-packages-by-name)) - - ;; Use 'find-best-packages-by-name' and not 'find-packages-by-name'; the - ;; former traverses the module tree only once and then allows for efficient - ;; access via a vhash. - (match (find-best-packages-by-name name version) - ((p _ ...) p) - (_ - (match (find-best-packages-by-name name #f) - ((p _ ...) p) - (_ #f))))) + #~(manifest (version #$format-version) + (packages #$(run-with-state + (mapm %state-monad entry->gexp entries) + vlist-null)))))) (define (sexp->manifest sexp) "Parse SEXP as a manifest." - (define (infer-search-paths name version) - ;; Infer the search path specifications for NAME-VERSION by looking up a - ;; same-named package in the distro. Useful for the old manifest formats - ;; that did not store search path info. - (let ((package (find-package name version))) - (if package - (package-native-search-paths package) - '()))) - (define (infer-dependency item parent) ;; Return a <manifest-entry> for ITEM. (let-values (((name version) @@ -521,14 +538,15 @@ procedure is here for backward-compatibility and will eventually vanish." (item item) (parent parent)))) - (define* (sexp->manifest-entry sexp #:optional (parent (delay #f))) + (define* (sexp->manifest-entry/v3 sexp #:optional (parent (delay #f))) + ;; Read SEXP as a version 3 manifest entry. (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)) + (letrec* ((deps* (map (cut sexp->manifest-entry/v3 <> (delay entry)) deps)) (entry (manifest-entry (name name) @@ -543,45 +561,58 @@ procedure is here for backward-compatibility and will eventually vanish." '()))))) entry)))) + (define-syntax let-fields + (syntax-rules () + ;; Bind the fields NAME of LST to same-named variables in the lexical + ;; scope of BODY. + ((_ lst (name rest ...) body ...) + (let ((name (match (assq 'name lst) + ((_ value) value) + (#f '())))) + (let-fields lst (rest ...) body ...))) + ((_ lst () body ...) + (begin body ...)))) + + (define* (sexp->manifest-entry sexp #:optional (parent (delay #f))) + (match sexp + (('repeated name version path) + ;; This entry is the same as another one encountered earlier; look it + ;; up and return it. + (mlet %state-monad ((visited (current-state)) + (key -> (list name version path))) + (match (vhash-assoc key visited) + (#f + (raise (formatted-message + (G_ "invalid repeated entry in profile: ~s") + sexp))) + ((_ . entry) + (return entry))))) + ((name version output path fields ...) + (let-fields fields (propagated-inputs search-paths properties) + (mlet* %state-monad + ((entry -> #f) + (deps (mapm %state-monad + (cut sexp->manifest-entry <> (delay entry)) + propagated-inputs)) + (visited (current-state)) + (key -> (list name version path))) + (set! entry ;XXX: emulate 'letrec*' + (manifest-entry + (name name) + (version version) + (output output) + (item path) + (dependencies deps) + (search-paths (map sexp->search-path-specification + search-paths)) + (parent parent) + (properties properties))) + (mbegin %state-monad + (set-current-state (vhash-cons key entry visited)) + (return entry))))))) + (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 version output path))) - - ;; Version 1 adds a list of propagated inputs to the - ;; name/version/output/path tuples. - (('manifest ('version 1) - ('packages ((name version output path deps) ...))) - (manifest - (map (lambda (name version output path deps) - ;; Up to Guix 0.7 included, dependencies were listed as ("gmp" - ;; "/gnu/store/...-gmp") for instance. Discard the 'label' in - ;; such lists. - (let ((deps (match deps - (((labels directories) ...) - directories) - ((directories ...) - directories)))) - (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))) + ;; Versions 0 and 1 are no longer produced since 2015. ;; Version 2 adds search paths and is slightly more verbose. (('manifest ('version 2 minor-version ...) @@ -609,7 +640,15 @@ procedure is here for backward-compatibility and will eventually vanish." ;; Version 3 represents DEPS as full-blown manifest entries. (('manifest ('version 3 minor-version ...) ('packages (entries ...))) - (manifest (map sexp->manifest-entry entries))) + (manifest (map sexp->manifest-entry/v3 entries))) + + ;; Version 4 deduplicates repeated entries and makes manifest entry fields + ;; such as 'propagated-inputs' and 'search-paths' optional. + (('manifest ('version 4 minor-version ...) + ('packages (entries ...))) + (manifest (run-with-state + (mapm %state-monad sexp->manifest-entry entries) + vlist-null))) (_ (raise (condition (&message (message "unsupported manifest format"))))))) @@ -1862,6 +1901,7 @@ MANIFEST." (allow-unsupported-packages? #f) (allow-collisions? #f) (relative-symlinks? #f) + (format-version %manifest-format-version) system target) "Return a derivation that builds a profile (aka. 'user environment') with the given MANIFEST. The profile includes additional derivations returned by @@ -1947,7 +1987,7 @@ are cross-built for TARGET." #+(if locales? set-utf8-locale #t) - (build-profile #$output '#$(manifest->gexp manifest) + (build-profile #$output '#$(manifest->gexp manifest format-version) #:extra-inputs '#$extra-inputs #:symlink #$(if relative-symlinks? #~symlink-relative @@ -1986,19 +2026,23 @@ are cross-built for TARGET." (allow-collisions? profile-allow-collisions? ;Boolean (default #f)) (relative-symlinks? profile-relative-symlinks? ;Boolean - (default #f))) + (default #f)) + (format-version profile-format-version ;integer + (default %manifest-format-version))) (define-gexp-compiler (profile-compiler (profile <profile>) system target) "Compile PROFILE to a derivation." (match profile (($ <profile> name manifest hooks - locales? allow-collisions? relative-symlinks?) + locales? allow-collisions? relative-symlinks? + format-version) (profile-derivation manifest #:name name #:hooks hooks #:locales? locales? #:allow-collisions? allow-collisions? #:relative-symlinks? relative-symlinks? + #:format-version format-version #:system system #:target target)))) (define* (profile-search-paths profile @@ -2318,4 +2362,8 @@ PROFILE refers to, directly or indirectly, or PROFILE." %known-shorthand-profiles) profile)) +;;; Local Variables: +;;; eval: (put 'let-fields 'scheme-indent-function 2) +;;; End: + ;;; profiles.scm ends here |