Merge branch 'staging' into core-updates

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