guix package: Introduce <manifest> and <manifest-entry> types.

* guix/scripts/package.scm (<manifest>, <manifest-entry>): New record
  types.
  (make-manifest, read-manifest, manifest->sexp, sexp->manifest,
  read-manifest, write-manifest, remove-manifest-entry, manifest-remove,
  manifest-installed?): New procedures.
  (profile-derivation): Take a manifest as the second parameter.  Use
  'manifest->sexp'.  Expect <manifest-entry> objects instead of
  "tuples".  Adjust callers accordingly.
  (search-path-environment-variables): Changes 'packages' parameter to
  'entries'.  Rename 'package-in-manifest->package' to
  'manifest-entry->package'; expect <manifest-entry> objects.
  (display-search-paths): Rename 'packages' to 'entries'.
  (options->installable): Change 'installed' to 'manifest'.  Have
  'canonicalize-deps' return name/path tuples instead of raw packages.
  Rename 'package->tuple' to 'package->manifest-entry'.  Use
  <manifest-entry> objects instead of tuples.
  (guix-package)[process-actions]: Likewise.  Rename 'packages' to
  'entries'.
  [process-query]: Use 'manifest-entries' instead of
  'manifest-packages'.

1 files changed, 180 insertions, 87 deletions

diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index c71cf8e76c..c67c682108 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -25,6 +25,7 @@
   #:use-module (guix packages)
   #:use-module (guix utils)
   #:use-module (guix config)
+  #:use-module (guix records)
   #:use-module ((guix build utils) #:select (directory-exists? mkdir-p))
   #:use-module ((guix ftp-client) #:select (ftp-open))
   #:use-module (ice-9 ftw)
@@ -33,6 +34,7 @@
   #:use-module (ice-9 regex)
   #:use-module (ice-9 vlist)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
@@ -67,30 +69,116 @@
   ;; coexist with Nix profiles.
   (string-append %profile-directory "/guix-profile"))
 
+
+;;;
+;;; Manifests.
+;;;
+
+(define-record-type <manifest>
+  (manifest entries)
+  manifest?
+  (entries manifest-entries))                     ; list of <manifest-entry>
+
+;; Convenient alias, to avoid name clashes.
+(define make-manifest manifest)
+
+(define-record-type* <manifest-entry> manifest-entry
+  make-manifest-entry
+  manifest-entry?
+  (name         manifest-entry-name)              ; string
+  (version      manifest-entry-version)           ; string
+  (output       manifest-entry-output             ; string
+                (default "out"))
+  (path         manifest-entry-path)              ; store path
+  (dependencies manifest-entry-dependencies       ; list of store paths
+                (default '())))
+
 (define (profile-manifest profile)
   "Return the PROFILE's manifest."
-  (let ((manifest (string-append profile "/manifest")))
-    (if (file-exists? manifest)
-        (call-with-input-file manifest read)
-        '(manifest (version 1) (packages ())))))
+  (let ((file (string-append profile "/manifest")))
+    (if (file-exists? file)
+        (call-with-input-file file read-manifest)
+        (manifest '()))))
+
+(define (manifest->sexp manifest)
+  "Return a representation of MANIFEST as an sexp."
+  (define (entry->sexp entry)
+    (match entry
+      (($ <manifest-entry> name version path output (deps ...))
+       (list name version path output deps))))
 
-(define (manifest-packages manifest)
-  "Return the packages listed in MANIFEST."
   (match manifest
+    (($ <manifest> (entries ...))
+     `(manifest (version 1)
+                (packages ,(map entry->sexp entries))))))
+
+(define (sexp->manifest sexp)
+  "Parse SEXP as a manifest."
+  (match sexp
     (('manifest ('version 0)
                 ('packages ((name version output path) ...)))
-     (zip name version output path
-          (make-list (length name) '())))
+     (manifest
+      (map (lambda (name version output path)
+             (manifest-entry
+              (name name)
+              (version version)
+              (output output)
+              (path path)))
+           name version output path)))
 
     ;; Version 1 adds a list of propagated inputs to the
     ;; name/version/output/path tuples.
     (('manifest ('version 1)
-                ('packages (packages ...)))
-     packages)
+                ('packages ((name version output path deps) ...)))
+     (manifest
+      (map (lambda (name version output path deps)
+             (manifest-entry
+              (name name)
+              (version version)
+              (output output)
+              (path path)
+              (dependencies deps)))
+           name version output path deps)))
 
     (_
      (error "unsupported manifest format" manifest))))
 
+(define (read-manifest port)
+  "Return the packages listed in MANIFEST."
+  (sexp->manifest (read port)))
+
+(define (write-manifest manifest port)
+  "Write MANIFEST to PORT."
+  (write (manifest->sexp manifest) port))
+
+(define (remove-manifest-entry name lst)
+  "Remove the manifest entry named NAME from LST."
+  (remove (match-lambda
+           (($ <manifest-entry> entry-name)
+            (string=? name entry-name)))
+          lst))
+
+(define (manifest-remove manifest names)
+  "Remove entries for each of NAMES from MANIFEST."
+  (make-manifest (fold remove-manifest-entry
+                       (manifest-entries manifest)
+                       names)))
+
+(define (manifest-installed? manifest name)
+  "Return #t if MANIFEST has an entry for NAME, #f otherwise."
+  (define (->bool x)
+    (not (not x)))
+
+  (->bool (find (match-lambda
+                 (($ <manifest-entry> entry-name)
+                  (string=? entry-name name)))
+                (manifest-entries manifest))))
+
+
+;;;
+;;; Profiles.
+;;;
+
 (define (profile-regexp profile)
   "Return a regular expression that matches PROFILE's name and number."
   (make-regexp (string-append "^" (regexp-quote (basename profile))
@@ -157,17 +245,9 @@ case when generations have been deleted (there are \"holes\")."
         0
         (generation-numbers profile)))
 
-(define (profile-derivation store packages)
-  "Return a derivation that builds a profile (a user environment) with
-all of PACKAGES, a list of name/version/output/path/deps tuples."
-  (define packages*
-    ;; Turn any package object in PACKAGES into its output path.
-    (map (match-lambda
-          ((name version output path (deps ...))
-           `(,name ,version ,output ,path
-                   ,(map input->name+path deps))))
-         packages))
-
+(define (profile-derivation store manifest)
+  "Return a derivation that builds a profile (a user environment) with the
+given MANIFEST."
   (define builder
     `(begin
        (use-modules (ice-9 pretty-print)
@@ -183,9 +263,7 @@ all of PACKAGES, a list of name/version/output/path/deps tuples."
          (union-build output inputs)
          (call-with-output-file (string-append output "/manifest")
            (lambda (p)
-             (pretty-print '(manifest (version 1)
-                                      (packages ,packages*))
-                           p))))))
+             (pretty-print ',(manifest->sexp manifest) p))))))
 
   (define ensure-valid-input
     ;; If a package object appears in the given input, turn it into a
@@ -200,11 +278,12 @@ all of PACKAGES, a list of name/version/output/path/deps tuples."
                                 (%current-system)
                                 builder
                                 (append-map (match-lambda
-                                             ((name version output path deps)
+                                             (($ <manifest-entry> name version
+                                                 output path deps)
                                               `((,name ,path)
                                                 ,@(map ensure-valid-input
                                                        deps))))
-                                            packages)
+                                            (manifest-entries manifest))
                                 #:modules '((guix build union))))
 
 (define (generation-number profile)
@@ -216,7 +295,7 @@ all of PACKAGES, a list of name/version/output/path/deps tuples."
 
 (define (link-to-empty-profile generation)
   "Link GENERATION, a string, to the empty profile."
-  (let* ((drv  (profile-derivation (%store) '()))
+  (let* ((drv  (profile-derivation (%store) (manifest '())))
          (prof (derivation->output-path drv "out")))
     (when (not (build-derivations (%store) (list drv)))
           (leave (_ "failed to build the empty profile~%")))
@@ -513,11 +592,11 @@ but ~a is available upstream~%")
 ;;; Search paths.
 ;;;
 
-(define* (search-path-environment-variables packages profile
+(define* (search-path-environment-variables entries profile
                                             #:optional (getenv getenv))
   "Return environment variable definitions that may be needed for the use of
-PACKAGES in PROFILE.  Use GETENV to determine the current settings and report
-only settings not already effective."
+ENTRIES, a list of manifest entries, in PROFILE.  Use GETENV to determine the
+current settings and report only settings not already effective."
 
   ;; Prefer ~/.guix-profile to the real profile directory name.
   (let ((profile (if (and %user-environment-directory
@@ -530,9 +609,9 @@ only settings not already effective."
     ;; The search path info is not stored in the manifest.  Thus, we infer the
     ;; search paths from same-named packages found in the distro.
 
-    (define package-in-manifest->package
+    (define manifest-entry->package
       (match-lambda
-       ((name version _ ...)
+       (($ <manifest-entry> name version)
         (match (append (find-packages-by-name name version)
                        (find-packages-by-name name))
           ((p _ ...) p)
@@ -554,16 +633,16 @@ only settings not already effective."
                       variable
                       (string-join directories separator)))))))
 
-    (let* ((packages     (filter-map package-in-manifest->package packages))
+    (let* ((packages     (filter-map manifest-entry->package entries))
            (search-paths (delete-duplicates
                           (append-map package-native-search-paths
                                       packages))))
       (filter-map search-path-definition search-paths))))
 
-(define (display-search-paths packages profile)
+(define (display-search-paths entries profile)
   "Display the search path environment variables that may need to be set for
-PACKAGES, in the context of PROFILE."
-  (let ((settings (search-path-environment-variables packages profile)))
+ENTRIES, a list of manifest entries, in the context of PROFILE."
+  (let ((settings (search-path-environment-variables entries profile)))
     (unless (null? settings)
       (format #t (_ "The following environment variable definitions may be needed:~%"))
       (format #t "~{   ~a~%~}" settings))))
@@ -709,13 +788,14 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
                   (cons `(query list-available ,(or arg ""))
                         result)))))
 
-(define (options->installable opts installed)
-  "Given INSTALLED, the set of currently installed packages, and OPTS, the
-result of 'args-fold', return two values: the new list of manifest entries,
-and the list of derivations that need to be built."
+(define (options->installable opts manifest)
+  "Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold',
+return two values: the new list of manifest entries, and the list of
+derivations that need to be built."
   (define (canonicalize-deps deps)
     ;; Remove duplicate entries from DEPS, a list of propagated inputs,
-    ;; where each input is a name/path tuple.
+    ;; where each input is a name/path tuple, and replace package objects with
+    ;; store paths.
     (define (same? d1 d2)
       (match d1
         ((_ p1)
@@ -729,21 +809,27 @@ and the list of derivations that need to be built."
                  (eq? p1 p2)))
            (_ #f)))))
 
-    (delete-duplicates deps same?))
-
-  (define* (package->tuple p #:optional output)
-    ;; Convert package P to a manifest tuple.
+    (map (match-lambda
+          ((name package)
+           (list name (package-output (%store) package)))
+          ((name package output)
+           (list name (package-output (%store) package output))))
+         (delete-duplicates deps same?)))
+
+  (define (package->manifest-entry p output)
+    ;; Return a manifest entry for the OUTPUT of package P.
+    (check-package-freshness p)
     ;; When given a package via `-e', install the first of its
     ;; outputs (XXX).
-    (check-package-freshness p)
     (let* ((output (or output (car (package-outputs p))))
            (path   (package-output (%store) p output))
            (deps   (package-transitive-propagated-inputs p)))
-      `(,(package-name p)
-        ,(package-version p)
-        ,output
-        ,path
-        ,(canonicalize-deps deps))))
+      (manifest-entry
+       (name (package-name p))
+       (version (package-version p))
+       (output output)
+       (path path)
+       (dependencies (canonicalize-deps deps)))))
 
   (define upgrade-regexps
     (filter-map (match-lambda
@@ -759,7 +845,7 @@ and the list of derivations that need to be built."
       ((_ ...)
        (let ((newest (find-newest-available-packages)))
          (filter-map (match-lambda
-                      ((name version output path _)
+                      (($ <manifest-entry> name version output path _)
                        (and (any (cut regexp-exec <> name)
                                  upgrade-regexps)
                             (upgradeable? name version path)
@@ -769,12 +855,12 @@ and the list of derivations that need to be built."
                                     (specification->package+output name output))
                                 list))))
                       (_ #f))
-                     installed)))))
+                     (manifest-entries manifest))))))
 
   (define to-upgrade
     (map (match-lambda
           ((package output)
-           (package->tuple package output)))
+           (package->manifest-entry package output)))
          packages-to-upgrade))
 
   (define packages-to-install
@@ -792,7 +878,7 @@ and the list of derivations that need to be built."
   (define to-install
     (append (map (match-lambda
                   ((package output)
-                   (package->tuple package output)))
+                   (package->manifest-entry package output)))
                  packages-to-install)
             (filter-map (match-lambda
                          (('install . (? package?))
@@ -801,7 +887,11 @@ and the list of derivations that need to be built."
                           (let-values (((name version)
                                         (package-name->name+version
                                          (store-path-package-name path))))
-                            `(,name ,version #f ,path ())))
+                            (manifest-entry
+                             (name name)
+                             (version version)
+                             (output #f)
+                             (path path))))
                          (_ #f))
                         opts)))
 
@@ -888,17 +978,17 @@ more information.~%"))
     (define verbose? (assoc-ref opts 'verbose?))
     (define profile  (assoc-ref opts 'profile))
 
-    (define (same-package? tuple name out)
-      (match tuple
-        ((tuple-name _ tuple-output _ ...)
-         (and (equal? name tuple-name)
-              (equal? out tuple-output)))))
+    (define (same-package? entry name output)
+      (match entry
+        (($ <manifest-entry> entry-name _ entry-output _ ...)
+         (and (equal? name entry-name)
+              (equal? output entry-output)))))
 
     (define (show-what-to-remove/install remove install dry-run?)
       ;; Tell the user what's going to happen in high-level terms.
       ;; TODO: Report upgrades more clearly.
       (match remove
-        (((name version _ path _) ..1)
+        ((($ <manifest-entry> name version _ path _) ..1)
          (let ((len    (length name))
                (remove (map (cut format #f "  ~a-~a\t~a" <> <> <>)
                             name version path)))
@@ -915,7 +1005,7 @@ more information.~%"))
                        remove))))
         (_ #f))
       (match install
-        (((name version output path _) ..1)
+        ((($ <manifest-entry> name version output path _) ..1)
          (let ((len     (length name))
                (install (map (cut format #f "   ~a-~a\t~a\t~a" <> <> <> <>)
                              name version output path)))
@@ -999,26 +1089,28 @@ more information.~%"))
              (_ #f))
             opts))
           (else
-           (let*-values (((installed)
-                          (manifest-packages (profile-manifest profile)))
+           (let*-values (((manifest)
+                          (profile-manifest profile))
                          ((install* drv)
-                          (options->installable opts installed)))
-             (let* ((remove (filter-map (match-lambda
-                                         (('remove . package)
-                                          package)
-                                         (_ #f))
-                                        opts))
-                    (remove* (filter-map (cut assoc <> installed) remove))
-                    (packages
+                          (options->installable opts manifest)))
+             (let* ((remove  (filter-map (match-lambda
+                                          (('remove . package)
+                                           package)
+                                          (_ #f))
+                                         opts))
+                    (remove* (filter (cut manifest-installed? manifest <>)
+                                     remove))
+                    (entries
                      (append install*
                              (fold (lambda (package result)
                                      (match package
-                                       ((name _ out _ ...)
+                                       (($ <manifest-entry> name _ out _ ...)
                                         (filter (negate
                                                  (cut same-package? <>
                                                       name out))
                                                 result))))
-                                   (fold alist-delete installed remove)
+                                   (manifest-entries
+                                    (manifest-remove manifest remove))
                                    install*))))
 
                (when (equal? profile %current-profile)
@@ -1031,11 +1123,12 @@ more information.~%"))
 
                (or dry-run?
                    (and (build-derivations (%store) drv)
-                        (let* ((prof-drv (profile-derivation (%store) packages))
+                        (let* ((prof-drv (profile-derivation (%store)
+                                                             (make-manifest
+                                                              entries)))
                                (prof     (derivation->output-path prof-drv))
                                (old-drv  (profile-derivation
-                                          (%store) (manifest-packages
-                                                    (profile-manifest profile))))
+                                          (%store) (profile-manifest profile)))
                                (old-prof (derivation->output-path old-drv))
                                (number   (generation-number profile))
 
@@ -1055,14 +1148,14 @@ more information.~%"))
                                                        (current-error-port)
                                                        (%make-void-port "w"))))
                                      (build-derivations (%store) (list prof-drv)))
-                                   (let ((count (length packages)))
+                                   (let ((count (length entries)))
                                      (switch-symlinks name prof)
                                      (switch-symlinks profile name)
                                      (format #t (N_ "~a package in profile~%"
                                                     "~a packages in profile~%"
                                                     count)
                                              count)
-                                     (display-search-paths packages
+                                     (display-search-paths entries
                                                            profile))))))))))))
 
   (define (process-query opts)
@@ -1083,13 +1176,13 @@ more information.~%"))
                    (format #t (_ "~a\t(current)~%") header)
                    (format #t "~a~%" header)))
              (for-each (match-lambda
-                        ((name version output location _)
+                        (($ <manifest-entry> name version output location _)
                          (format #t "  ~a\t~a\t~a\t~a~%"
                                  name version output location)))
 
                        ;; Show most recently installed packages last.
                        (reverse
-                        (manifest-packages
+                        (manifest-entries
                          (profile-manifest
                           (format #f "~a-~a-link" profile number)))))
              (newline)))
@@ -1116,9 +1209,9 @@ more information.~%"))
         (('list-installed regexp)
          (let* ((regexp    (and regexp (make-regexp regexp)))
                 (manifest  (profile-manifest profile))
-                (installed (manifest-packages manifest)))
+                (installed (manifest-entries manifest)))
            (for-each (match-lambda
-                      ((name version output path _)
+                      (($ <manifest-entry> name version output path _)
                        (when (or (not regexp)
                                  (regexp-exec regexp name))
                          (format #t "~a\t~a\t~a\t~a~%"
@@ -1159,9 +1252,9 @@ more information.~%"))
 
         (('search-paths)
          (let* ((manifest (profile-manifest profile))
-                (packages (manifest-packages manifest))
-                (settings (search-path-environment-variables packages
-                                                             profile
+                (entries  (manifest-entries manifest))
+                (packages (map manifest-entry-name entries))
+                (settings (search-path-environment-variables entries profile
                                                              (const #f))))
            (format #t "~{~a~%~}" settings)
            #t))