diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/profiles.scm | 93 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 2 | ||||
| -rw-r--r-- | guix/ui.scm | 93 |
3 files changed, 94 insertions, 94 deletions
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." |