ui: Move 'show-manifest-transaction' from (guix profiles).

* guix/profiles.scm: Do not use (guix ui) module.
  (right-arrow, manifest-show-transaction): Move and rename to...
* guix/ui.scm (right-arrow, show-manifest-transaction): ... here.
* tests/profiles.scm ("manifest-show-transaction"): Move to...
* tests/ui.scm ("show-manifest-transaction"): ... here.
  (guile-1.8.8, guile-2.0.9): New variables.
* emacs/guix-main.scm (process-package-actions): Rename
  'manifest-show-transaction' to 'show-manifest-transaction'.
* guix/scripts/package.scm (guix-package): Likewise.

Signed-off-by: Ludovic Courtès <ludo@gnu.org>

emacs/guix-main.scm

@@ -797,7 +797,7 @@ OUTPUTS is a list of package outputs (may be an empty list)."
                (new-profile (derivation->output-path derivation)))
           (set-build-options store
                              #:use-substitutes? use-substitutes?)
-          (manifest-show-transaction store manifest transaction
+          (show-manifest-transaction store manifest transaction
                                      #:dry-run? dry-run?)
           (show-what-to-build store derivations
                               #:use-substitutes? use-substitutes?

guix/profiles.scm

@@ -19,7 +19,6 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guix profiles)
-  #:use-module (guix ui)
   #:use-module (guix utils)
   #:use-module (guix records)
   #:use-module (guix derivations)
@@ -63,7 +62,6 @@
             manifest-transaction-remove
             manifest-perform-transaction
             manifest-transaction-effects
-            manifest-show-transaction
 
             profile-manifest
             package->manifest-entry
@@ -315,97 +313,6 @@ it."
     (manifest-add (manifest-remove manifest remove)
                   install)))
 
-(define (right-arrow port)
-  "Return either a string containing the 'RIGHT ARROW' character, or an ASCII
-replacement if PORT is not Unicode-capable."
-  (with-fluids ((%default-port-encoding (port-encoding port)))
-    (let ((arrow "→"))
-      (catch 'encoding-error
-        (lambda ()
-          (call-with-output-string
-            (lambda (port)
-              (set-port-conversion-strategy! port 'error)
-              (display arrow port))))
-        (lambda (key . args)
-          "->")))))
-
-(define* (manifest-show-transaction store manifest transaction
-                                    #:key dry-run?)
-  "Display what will/would be installed/removed from MANIFEST by TRANSACTION."
-  (define (package-strings name version output item)
-    (map (lambda (name version output item)
-           (format #f "   ~a~:[:~a~;~*~]\t~a\t~a"
-                   name
-                   (equal? output "out") output version
-                   (if (package? item)
-                       (package-output store item output)
-                       item)))
-         name version output item))
-
-  (define →                        ;an arrow that can be represented on stderr
-    (right-arrow (current-error-port)))
-
-  (define (upgrade-string name old-version new-version output item)
-    (format #f "   ~a~:[:~a~;~*~]\t~a ~a ~a\t~a"
-            name (equal? output "out") output
-            old-version → new-version
-            (if (package? item)
-                (package-output store item output)
-                item)))
-
-  (let-values (((remove install upgrade)
-                (manifest-transaction-effects manifest transaction)))
-    (match remove
-      ((($ <manifest-entry> name version output item) ..1)
-       (let ((len    (length name))
-             (remove (package-strings name version output item)))
-         (if dry-run?
-             (format (current-error-port)
-                     (N_ "The following package would be removed:~%~{~a~%~}~%"
-                         "The following packages would be removed:~%~{~a~%~}~%"
-                         len)
-                     remove)
-             (format (current-error-port)
-                     (N_ "The following package will be removed:~%~{~a~%~}~%"
-                         "The following packages will be removed:~%~{~a~%~}~%"
-                         len)
-                     remove))))
-      (_ #f))
-    (match upgrade
-      (((($ <manifest-entry> name old-version)
-         . ($ <manifest-entry> _ new-version output item)) ..1)
-       (let ((len     (length name))
-             (upgrade (map upgrade-string
-                           name old-version new-version output item)))
-         (if dry-run?
-             (format (current-error-port)
-                     (N_ "The following package would be upgraded:~%~{~a~%~}~%"
-                         "The following packages would be upgraded:~%~{~a~%~}~%"
-                         len)
-                     upgrade)
-             (format (current-error-port)
-                     (N_ "The following package will be upgraded:~%~{~a~%~}~%"
-                         "The following packages will be upgraded:~%~{~a~%~}~%"
-                         len)
-                     upgrade))))
-      (_ #f))
-    (match install
-      ((($ <manifest-entry> name version output item _) ..1)
-       (let ((len     (length name))
-             (install (package-strings name version output item)))
-         (if dry-run?
-             (format (current-error-port)
-                     (N_ "The following package would be installed:~%~{~a~%~}~%"
-                         "The following packages would be installed:~%~{~a~%~}~%"
-                         len)
-                     install)
-             (format (current-error-port)
-                     (N_ "The following package will be installed:~%~{~a~%~}~%"
-                         "The following packages will be installed:~%~{~a~%~}~%"
-                         len)
-                     install))))
-      (_ #f))))
-
 
 ;;;
 ;;; Profiles.

guix/scripts/package.scm

@@ -770,7 +770,7 @@ more information.~%"))
                                    new
                                    #:info-dir? (not bootstrap?))))
                       (prof     (derivation->output-path prof-drv)))
-                 (manifest-show-transaction (%store) manifest transaction
+                 (show-manifest-transaction (%store) manifest transaction
                                             #:dry-run? dry-run?)
                  (show-what-to-build (%store) (list prof-drv)
                                      #:use-substitutes?

guix/ui.scm

@@ -23,6 +23,7 @@
   #:use-module (guix store)
   #:use-module (guix config)
   #:use-module (guix packages)
+  #:use-module (guix profiles)
   #:use-module (guix build-system)
   #:use-module (guix derivations)
   #:use-module ((guix build utils) #:select (mkdir-p))
@@ -47,6 +48,7 @@
             string->number*
             size->number
             show-what-to-build
+            show-manifest-transaction
             call-with-error-handling
             with-error-handling
             read/eval
@@ -348,6 +350,97 @@ available for download."
                   (null? download) download)))
     (pair? build)))
 
+(define (right-arrow port)
+  "Return either a string containing the 'RIGHT ARROW' character, or an ASCII
+replacement if PORT is not Unicode-capable."
+  (with-fluids ((%default-port-encoding (port-encoding port)))
+    (let ((arrow "→"))
+      (catch 'encoding-error
+        (lambda ()
+          (call-with-output-string
+            (lambda (port)
+              (set-port-conversion-strategy! port 'error)
+              (display arrow port))))
+        (lambda (key . args)
+          "->")))))
+
+(define* (show-manifest-transaction store manifest transaction
+                                    #:key dry-run?)
+  "Display what will/would be installed/removed from MANIFEST by TRANSACTION."
+  (define (package-strings name version output item)
+    (map (lambda (name version output item)
+           (format #f "   ~a~:[:~a~;~*~]\t~a\t~a"
+                   name
+                   (equal? output "out") output version
+                   (if (package? item)
+                       (package-output store item output)
+                       item)))
+         name version output item))
+
+  (define →                        ;an arrow that can be represented on stderr
+    (right-arrow (current-error-port)))
+
+  (define (upgrade-string name old-version new-version output item)
+    (format #f "   ~a~:[:~a~;~*~]\t~a ~a ~a\t~a"
+            name (equal? output "out") output
+            old-version → new-version
+            (if (package? item)
+                (package-output store item output)
+                item)))
+
+  (let-values (((remove install upgrade)
+                (manifest-transaction-effects manifest transaction)))
+    (match remove
+      ((($ <manifest-entry> name version output item) ..1)
+       (let ((len    (length name))
+             (remove (package-strings name version output item)))
+         (if dry-run?
+             (format (current-error-port)
+                     (N_ "The following package would be removed:~%~{~a~%~}~%"
+                         "The following packages would be removed:~%~{~a~%~}~%"
+                         len)
+                     remove)
+             (format (current-error-port)
+                     (N_ "The following package will be removed:~%~{~a~%~}~%"
+                         "The following packages will be removed:~%~{~a~%~}~%"
+                         len)
+                     remove))))
+      (_ #f))
+    (match upgrade
+      (((($ <manifest-entry> name old-version)
+         . ($ <manifest-entry> _ new-version output item)) ..1)
+       (let ((len     (length name))
+             (upgrade (map upgrade-string
+                           name old-version new-version output item)))
+         (if dry-run?
+             (format (current-error-port)
+                     (N_ "The following package would be upgraded:~%~{~a~%~}~%"
+                         "The following packages would be upgraded:~%~{~a~%~}~%"
+                         len)
+                     upgrade)
+             (format (current-error-port)
+                     (N_ "The following package will be upgraded:~%~{~a~%~}~%"
+                         "The following packages will be upgraded:~%~{~a~%~}~%"
+                         len)
+                     upgrade))))
+      (_ #f))
+    (match install
+      ((($ <manifest-entry> name version output item _) ..1)
+       (let ((len     (length name))
+             (install (package-strings name version output item)))
+         (if dry-run?
+             (format (current-error-port)
+                     (N_ "The following package would be installed:~%~{~a~%~}~%"
+                         "The following packages would be installed:~%~{~a~%~}~%"
+                         len)
+                     install)
+             (format (current-error-port)
+                     (N_ "The following package will be installed:~%~{~a~%~}~%"
+                         "The following packages will be installed:~%~{~a~%~}~%"
+                         len)
+                     install))))
+      (_ #f))))
+
 (define-syntax with-error-handling
   (syntax-rules ()
     "Run BODY within a user-friendly error condition handler."

tests/profiles.scm

@@ -156,23 +156,6 @@
            (equal? (list glibc) install)
            (equal? (list (cons guile-1.8.8 guile-2.0.9)) upgrade)))))
 
-(test-assert "manifest-show-transaction"
-  (let* ((m (manifest (list guile-1.8.8)))
-         (t (manifest-transaction (install (list guile-2.0.9)))))
-    (let-values (((remove install upgrade)
-                  (manifest-transaction-effects m t)))
-      (with-store store
-        (and (string-match "guile\t1.8.8 → 2.0.9"
-                           (with-fluids ((%default-port-encoding "UTF-8"))
-                             (with-error-to-string
-                              (lambda ()
-                                (manifest-show-transaction store m t)))))
-             (string-match "guile\t1.8.8 -> 2.0.9"
-                           (with-fluids ((%default-port-encoding "ISO-8859-1"))
-                             (with-error-to-string
-                              (lambda ()
-                                (manifest-show-transaction store m t))))))))))
-
 (test-assert "profile-derivation"
   (run-with-store %store
     (mlet* %store-monad

tests/ui.scm

@@ -19,11 +19,14 @@
 
 (define-module (test-ui)
   #:use-module (guix ui)
+  #:use-module (guix profiles)
   #:use-module (guix store)
   #:use-module (guix derivations)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-19)
-  #:use-module (srfi srfi-64))
+  #:use-module (srfi srfi-64)
+  #:use-module (ice-9 regex))
 
 ;; Test the (guix ui) module.
 
@@ -35,6 +38,20 @@ R6RS, Guile includes a module system, full access to POSIX system calls,
 networking support, multiple threads, dynamic linking, a foreign function call
 interface, and powerful string processing.")
 
+(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")
+    (version "2.0.9")
+    (item "/gnu/store/...")
+    (output "out")))
+
 
 (test-begin "ui")
 
@@ -210,6 +227,23 @@ Second line" 24))
          ;; This should print nothing.
          (show-what-to-build store (list drv)))))))
 
+(test-assert "show-manifest-transaction"
+  (let* ((m (manifest (list guile-1.8.8)))
+         (t (manifest-transaction (install (list guile-2.0.9)))))
+    (let-values (((remove install upgrade)
+                  (manifest-transaction-effects m t)))
+      (with-store store
+        (and (string-match "guile\t1.8.8 → 2.0.9"
+                           (with-fluids ((%default-port-encoding "UTF-8"))
+                             (with-error-to-string
+                              (lambda ()
+                                (show-manifest-transaction store m t)))))
+             (string-match "guile\t1.8.8 -> 2.0.9"
+                           (with-fluids ((%default-port-encoding "ISO-8859-1"))
+                             (with-error-to-string
+                              (lambda ()
+                                (show-manifest-transaction store m t))))))))))
+
 (test-end "ui")