diff options
| -rw-r--r-- | emacs/guix-main.scm | 2 | ||||
| -rw-r--r-- | guix/profiles.scm | 93 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 2 | ||||
| -rw-r--r-- | guix/ui.scm | 93 | ||||
| -rw-r--r-- | tests/profiles.scm | 17 | ||||
| -rw-r--r-- | tests/ui.scm | 36 |
6 files changed, 130 insertions, 113 deletions
diff --git a/emacs/guix-main.scm b/emacs/guix-main.scm index b85bb5c8fe..fe599fbf11 100644 --- a/emacs/guix-main.scm +++ b/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? diff --git a/guix/profiles.scm b/guix/profiles.scm index 18733a6664..f2eb754bca 100644 --- a/guix/profiles.scm +++ b/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. diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index fc9c37b266..031f71a441 100644 --- a/guix/scripts/package.scm +++ b/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? diff --git a/guix/ui.scm b/guix/ui.scm index bf7226ca36..8c4a9d2d22 100644 --- a/guix/ui.scm +++ b/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." diff --git a/tests/profiles.scm b/tests/profiles.scm index 99f1fd2763..61c801c351 100644 --- a/tests/profiles.scm +++ b/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 diff --git a/tests/ui.scm b/tests/ui.scm index db90cdd479..236f541be2 100644 --- a/tests/ui.scm +++ b/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") |