[PATCH] Emacs interface for Guix

[Alex Kost <alezost@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 1126 bytes --]

Hello,

Ludovic Courtès (2014-08-12 00:54 +0400) wrote:

> Alex Kost <alezost@gmail.com> skribis:
>
>> - A part of code for installing/upgrading/removing was extracted from
>>   ‘guix-package’ function (from ‘process-actions’ more precisely).  So
>>   the new function (I named it ‘process-package-actions’) can be used in
>>   "guix.el".
>
> That looks good, but could you make it a separate patch?
>
> In general, it’s better to send atomic changes, with a commit log, in
> the format produced by ‘git format-patch’ (see HACKING.)  That
> facilitates review and incremental changes.

Thanks for pointing.  I've never contributed to a real project, so I
don't know the rules actually :)

>> - A bit of code was placed into "profiles.scm" as ‘manifest-add’.
>
> Good idea.  Could you send a single patch for this change?  I’ll even
> add a couple of test cases in tests/profiles.scm for the new procedure
> if you don’t do it yourself.  :-)

Ok, I'm attaching 2 patches with ‘manifest-add’ and
‘process-package-actions’.  What should be changed/improved there?


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-profiles-Add-manifest-add.patch --]
[-- Type: text/x-patch, Size: 2954 bytes --]

From af4b8495969d70d59aa9f3f296628daeaf80b0d2 Mon Sep 17 00:00:00 2001
From: Alex Kost <alezost@gmail.com>
Date: Tue, 12 Aug 2014 12:32:16 +0400
Subject: [PATCH 1/2] profiles: Add 'manifest-add'.

* guix/profiles.scm (manifest-add): New procedure.
* tests/profiles.scm (guile-1.8.8): New variable.
  ("manifest-add"): New test.
---
 guix/profiles.scm  | 20 ++++++++++++++++++++
 tests/profiles.scm | 21 +++++++++++++++++++++
 2 files changed, 41 insertions(+)

diff --git a/guix/profiles.scm b/guix/profiles.scm
index 5e69e01..c7aec79 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -47,6 +47,7 @@
             manifest-pattern?
 
             manifest-remove
+            manifest-add
             manifest-installed?
             manifest-matching-entries
 
@@ -196,6 +197,25 @@ must be a manifest-pattern."
                        (manifest-entries manifest)
                        patterns)))
 
+(define (manifest-add manifest entries)
+  "Add a list of manifest ENTRIES to MANIFEST and return new manifest.
+Remove MANIFEST entries that have the same name and output as ENTRIES."
+  (define (same-entry? entry name output)
+    (match entry
+      (($ <manifest-entry> entry-name _ entry-output _ ...)
+       (and (equal? name entry-name)
+            (equal? output entry-output)))))
+
+  (make-manifest
+   (append entries
+           (fold (lambda (entry result)
+                   (match entry
+                     (($ <manifest-entry> name _ out _ ...)
+                      (filter (negate (cut same-entry? <> name out))
+                              result))))
+                 (manifest-entries manifest)
+                 entries))))
+
 (define (manifest-installed? manifest pattern)
   "Return #t if MANIFEST has an entry matching PATTERN (a manifest-pattern),
 #f otherwise."
diff --git a/tests/profiles.scm b/tests/profiles.scm
index d405f64..b2919d7 100644
--- a/tests/profiles.scm
+++ b/tests/profiles.scm
@@ -40,6 +40,13 @@
 
 ;; Example manifest entries.
 
+(define guile-1.8.8
+  (manifest-entry
+    (name "guile")
+    (version "1.8.8")
+    (item "/gnu/store/...")
+    (output "out")))
+
 (define guile-2.0.9
   (manifest-entry
     (name "guile")
@@ -101,6 +108,20 @@
             (null? (manifest-entries m3))
             (null? (manifest-entries m4)))))))
 
+(test-assert "manifest-add"
+  (let* ((m0 (manifest '()))
+         (m1 (manifest-add m0 (list guile-1.8.8)))
+         (m2 (manifest-add m1 (list guile-2.0.9)))
+         (m3 (manifest-add m2 (list guile-2.0.9:debug)))
+         (m4 (manifest-add m3 (list guile-2.0.9:debug))))
+    (and (match (manifest-entries m1)
+           ((($ <manifest-entry> "guile" "1.8.8" "out")) #t)
+           (_ #f))
+         (match (manifest-entries m2)
+           ((($ <manifest-entry> "guile" "2.0.9" "out")) #t)
+           (_ #f))
+         (equal? m3 m4))))
+
 (test-assert "profile-derivation"
   (run-with-store %store
     (mlet* %store-monad
-- 
2.0.3


[-- Attachment #3: 0002-guix-package-Add-process-package-actions.patch --]
[-- Type: text/x-patch, Size: 17619 bytes --]

From 5fd45b3f4216921837f522d56b20c4be0a58fe8e Mon Sep 17 00:00:00 2001
From: Alex Kost <alezost@gmail.com>
Date: Tue, 12 Aug 2014 13:54:23 +0400
Subject: [PATCH 2/2] guix package: Add 'process-package-actions'.

* guix/scripts/package.scm (process-package-actions): New procedure.
  (guix-package): Use it.
  [ensure-default-profile]: Move to top-level.
  [substitutes?]: New variable.
  [same-package?]: Remove.
  (options->installable, options->removable): Change according to
  'process-package-actions'.
---
 guix/scripts/package.scm | 336 +++++++++++++++++++++++------------------------
 1 file changed, 166 insertions(+), 170 deletions(-)

diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 4eb046e..2719b74 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -44,6 +44,7 @@
   #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile))
   #:use-module (guix gnu-maintenance)
   #:export (specification->package+output
+            process-package-actions
             guix-package))
 
 (define %store
@@ -619,21 +620,15 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
 
          %standard-build-options))
 
-(define (options->installable opts manifest)
-  "Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold',
-return the new list of manifest entries."
-  (define (package->manifest-entry* package output)
-    (check-package-freshness package)
-    ;; When given a package via `-e', install the first of its
-    ;; outputs (XXX).
-    (package->manifest-entry package output))
-
+(define (options->installable options manifest)
+  "Given OPTIONS, return a list of patterns for installing/upgrading.
+Returned list is suitable for 'process-package-actions'."
   (define upgrade-regexps
     (filter-map (match-lambda
                  (('upgrade . regexp)
                   (make-regexp (or regexp "")))
                  (_ #f))
-                opts))
+                options))
 
   (define packages-to-upgrade
     (match upgrade-regexps
@@ -653,59 +648,18 @@ return the new list of manifest entries."
                     (_ #f))
                    (manifest-entries manifest)))))
 
-  (define to-upgrade
-    (map (match-lambda
-          ((package output)
-           (package->manifest-entry* package output)))
-         packages-to-upgrade))
-
   (define packages-to-install
     (filter-map (match-lambda
-                 (('install . (? package? p))
-                  (list p "out"))
-                 (('install . (? string? spec))
-                  (and (not (store-path? spec))
-                       (let-values (((package output)
-                                     (specification->package+output spec)))
-                         (and package (list package output)))))
+                 (('install . package) package)
                  (_ #f))
-                opts))
-
-  (define to-install
-    (append (map (match-lambda
-                  ((package output)
-                   (package->manifest-entry* package output)))
-                 packages-to-install)
-            (filter-map (match-lambda
-                         (('install . (? package?))
-                          #f)
-                         (('install . (? store-path? path))
-                          (let-values (((name version)
-                                        (package-name->name+version
-                                         (store-path-package-name path))))
-                            (manifest-entry
-                             (name name)
-                             (version version)
-                             (output #f)
-                             (item path))))
-                         (_ #f))
-                        opts)))
-
-  (append to-upgrade to-install))
-
-(define (options->removable options manifest)
-  "Given options, return the list of manifest patterns of packages to be
-removed from MANIFEST."
+                options))
+
+  (append packages-to-upgrade packages-to-install))
+
+(define (options->removable options)
+  "Given OPTIONS, return a list of package specifications for deleting."
   (filter-map (match-lambda
-               (('remove . spec)
-                (call-with-values
-                    (lambda ()
-                      (package-specification->name+version+output spec))
-                  (lambda (name version output)
-                    (manifest-pattern
-                      (name name)
-                      (version version)
-                      (output output)))))
+               (('remove . spec) spec)
                (_ #f))
               options))
 
@@ -724,6 +678,150 @@ removed from MANIFEST."
           file
           (apply throw args)))))
 
+(define (ensure-default-profile)
+  "Ensure the default profile symlink and directory exist and are
+writable."
+  (define (rtfm)
+    (format (current-error-port)
+            (_ "Try \"info '(guix) Invoking guix package'\" for \
+more information.~%"))
+    (exit 1))
+
+  ;; Create ~/.guix-profile if it doesn't exist yet.
+  (when (and %user-profile-directory
+             %current-profile
+             (not (false-if-exception
+                   (lstat %user-profile-directory))))
+    (symlink %current-profile %user-profile-directory))
+
+  (let ((s (stat %profile-directory #f)))
+    ;; Attempt to create /…/profiles/per-user/$USER if needed.
+    (unless (and s (eq? 'directory (stat:type s)))
+      (catch 'system-error
+        (lambda ()
+          (mkdir-p %profile-directory))
+        (lambda args
+          ;; Often, we cannot create %PROFILE-DIRECTORY because its
+          ;; parent directory is root-owned and we're running
+          ;; unprivileged.
+          (format (current-error-port)
+                  (_ "error: while creating directory `~a': ~a~%")
+                  %profile-directory
+                  (strerror (system-error-errno args)))
+          (format (current-error-port)
+                  (_ "Please create the `~a' directory, with you as the owner.~%")
+                  %profile-directory)
+          (rtfm))))
+
+    ;; Bail out if it's not owned by the user.
+    (unless (or (not s) (= (stat:uid s) (getuid)))
+      (format (current-error-port)
+              (_ "error: directory `~a' is not owned by you~%")
+              %profile-directory)
+      (format (current-error-port)
+              (_ "Please change the owner of `~a' to user ~s.~%")
+              %profile-directory (or (getenv "USER")
+                                     (getenv "LOGNAME")
+                                     (getuid)))
+      (rtfm))))
+
+(define* (process-package-actions store profile
+                                  #:key (install '()) (remove '())
+                                  dry-run? (use-substitutes? #t))
+  "Install/remove packages.
+
+INSTALL is a list of package patterns for installation.  Each element of
+the list may be a package, a list (PACKAGE OUTPUT), a string with name
+specification or a store path.
+
+REMOVE is a list of name specifications for removing from PROFILE
+manifest."
+  (define (package->manifest-entry* package output)
+    (check-package-freshness package)
+    ;; When given a package via `-e', install the first of its
+    ;; outputs (XXX).
+    (package->manifest-entry package output))
+
+  (define (entries-to-install install)
+    ;; Return a list of manifest entries for installing.
+    (filter-map (match-lambda
+                 ((? package? package)
+                  (package->manifest-entry* package "out"))
+                 (((? package? package) output)
+                  (package->manifest-entry* package output))
+                 ((? string? spec-or-path)
+                  (if (store-path? spec-or-path)
+                      (let-values (((name version)
+                                    (package-name->name+version
+                                     (store-path-package-name spec-or-path))))
+                        (manifest-entry
+                         (name name)
+                         (version version)
+                         (output #f)
+                         (item spec-or-path)))
+                      (let-values (((package output)
+                                    (specification->package+output spec-or-path)))
+                        (and package (package->manifest-entry* package output)))))
+                 (_ #f))
+                install))
+
+  (define (patterns-to-remove remove)
+    ;; Return a list of manifest patterns for removing.
+    (map (lambda (spec)
+           (call-with-values
+               (lambda ()
+                 (package-specification->name+version+output spec))
+             (lambda (name version output)
+               (manifest-pattern
+                (name name)
+                (version version)
+                (output output)))))
+         remove))
+
+  (let* ((manifest (profile-manifest profile))
+         (install  (entries-to-install install))
+         (remove   (patterns-to-remove remove))
+         (new      (manifest-add (manifest-remove manifest remove)
+                                 install))
+         (entries  (manifest-entries new)))
+
+    (unless (and (null? install) (null? remove))
+      (when (equal? profile %current-profile)
+        (ensure-default-profile))
+
+      (let* ((prof-drv (run-with-store store (profile-derivation new)))
+             (prof     (derivation->output-path prof-drv))
+             (remove   (manifest-matching-entries manifest remove)))
+        (show-what-to-remove/install remove install dry-run?)
+        (show-what-to-build store (list prof-drv)
+                            #:use-substitutes? use-substitutes?
+                            #:dry-run? dry-run?)
+
+        (cond
+         (dry-run? #t)
+         ((and (file-exists? profile)
+               (and=> (readlink* profile) (cut string=? prof <>)))
+          (format (current-error-port) (_ "nothing to be done~%")))
+         (else
+          (let* ((number (generation-number profile))
+
+                 ;; Always use NUMBER + 1 for the new profile,
+                 ;; possibly overwriting a "previous future
+                 ;; generation".
+                 (name   (generation-file-name profile
+                                               (+ 1 number))))
+            (and (build-derivations store (list prof-drv))
+                 (let ((count (length entries)))
+                   (switch-symlinks name prof)
+                   (switch-symlinks profile name)
+                   (maybe-register-gc-root store profile)
+                   (format #t (N_ "~a package in profile~%"
+                                  "~a packages in profile~%"
+                                  count)
+                           count)
+                   (display-search-paths entries
+                                         profile))))))))))
+
 \f
 ;;;
 ;;; Entry point.
@@ -742,65 +840,12 @@ removed from MANIFEST."
                 %default-options
                 #f))
 
-  (define (ensure-default-profile)
-    ;; Ensure the default profile symlink and directory exist and are
-    ;; writable.
-
-    (define (rtfm)
-      (format (current-error-port)
-              (_ "Try \"info '(guix) Invoking guix package'\" for \
-more information.~%"))
-      (exit 1))
-
-    ;; Create ~/.guix-profile if it doesn't exist yet.
-    (when (and %user-profile-directory
-               %current-profile
-               (not (false-if-exception
-                     (lstat %user-profile-directory))))
-      (symlink %current-profile %user-profile-directory))
-
-    (let ((s (stat %profile-directory #f)))
-      ;; Attempt to create /…/profiles/per-user/$USER if needed.
-      (unless (and s (eq? 'directory (stat:type s)))
-        (catch 'system-error
-          (lambda ()
-            (mkdir-p %profile-directory))
-          (lambda args
-            ;; Often, we cannot create %PROFILE-DIRECTORY because its
-            ;; parent directory is root-owned and we're running
-            ;; unprivileged.
-            (format (current-error-port)
-                    (_ "error: while creating directory `~a': ~a~%")
-                    %profile-directory
-                    (strerror (system-error-errno args)))
-            (format (current-error-port)
-                    (_ "Please create the `~a' directory, with you as the owner.~%")
-                    %profile-directory)
-            (rtfm))))
-
-      ;; Bail out if it's not owned by the user.
-      (unless (or (not s) (= (stat:uid s) (getuid)))
-        (format (current-error-port)
-                (_ "error: directory `~a' is not owned by you~%")
-                %profile-directory)
-        (format (current-error-port)
-                (_ "Please change the owner of `~a' to user ~s.~%")
-                %profile-directory (or (getenv "USER")
-                                       (getenv "LOGNAME")
-                                       (getuid)))
-        (rtfm))))
-
   (define (process-actions opts)
     ;; Process any install/remove/upgrade action from OPTS.
 
-    (define dry-run? (assoc-ref opts 'dry-run?))
-    (define profile  (assoc-ref opts 'profile))
-
-    (define (same-package? entry name output)
-      (match entry
-        (($ <manifest-entry> entry-name _ entry-output _ ...)
-         (and (equal? name entry-name)
-              (equal? output entry-output)))))
+    (define substitutes? (assoc-ref opts 'substitutes?))
+    (define dry-run?     (assoc-ref opts 'dry-run?))
+    (define profile      (assoc-ref opts 'profile))
 
     (define current-generation-number
       (generation-number profile))
@@ -869,61 +914,12 @@ more information.~%"))
              (_ #f))
             opts))
           (else
-           (let* ((manifest (profile-manifest profile))
-                  (install  (options->installable opts manifest))
-                  (remove   (options->removable opts manifest))
-                  (entries
-                   (append install
-                           (fold (lambda (package result)
-                                   (match package
-                                     (($ <manifest-entry> name _ out _ ...)
-                                      (filter (negate
-                                               (cut same-package? <>
-                                                    name out))
-                                              result))))
-                                 (manifest-entries
-                                  (manifest-remove manifest remove))
-                                 install)))
-                  (new      (make-manifest entries)))
-
-             (when (equal? profile %current-profile)
-               (ensure-default-profile))
-
-             (unless (and (null? install) (null? remove))
-               (let* ((prof-drv (run-with-store (%store)
-                                  (profile-derivation new)))
-                      (prof     (derivation->output-path prof-drv))
-                      (remove   (manifest-matching-entries manifest remove)))
-                 (show-what-to-remove/install remove install dry-run?)
-                 (show-what-to-build (%store) (list prof-drv)
-                                     #:use-substitutes?
-                                     (assoc-ref opts 'substitutes?)
-                                     #:dry-run? dry-run?)
-
-                 (cond
-                  (dry-run? #t)
-                  ((and (file-exists? profile)
-                        (and=> (readlink* profile) (cut string=? prof <>)))
-                   (format (current-error-port) (_ "nothing to be done~%")))
-                  (else
-                   (let* ((number (generation-number profile))
-
-                          ;; Always use NUMBER + 1 for the new profile,
-                          ;; possibly overwriting a "previous future
-                          ;; generation".
-                          (name   (generation-file-name profile
-                                                        (+ 1 number))))
-                     (and (build-derivations (%store) (list prof-drv))
-                          (let ((count (length entries)))
-                            (switch-symlinks name prof)
-                            (switch-symlinks profile name)
-                            (maybe-register-gc-root (%store) profile)
-                            (format #t (N_ "~a package in profile~%"
-                                           "~a packages in profile~%"
-                                           count)
-                                    count)
-                            (display-search-paths entries
-                                                  profile))))))))))))
+           (process-package-actions
+            (%store) profile
+            #:install (options->installable opts (profile-manifest profile))
+            #:remove  (options->removable opts)
+            #:use-substitutes? substitutes?
+            #:dry-run? dry-run?))))
 
   (define (process-query opts)
     ;; Process any query specified by OPTS.  Return #t when a query was
-- 
2.0.3