Add (guix status) and use it for pretty colored output.

* guix/progress.scm (progress-reporter/trace): New procedure.
(%progress-interval): New variable.
(progress-reporter/file): Use it.
* guix/scripts/build.scm (set-build-options-from-command-line): Pass
 #:print-extended-build-trace?.
(%default-options): Add 'print-extended-build-trace?'.
(guix-build): Parameterize CURRENT-TERMINAL-COLUMNS.  Use
'build-status-updater'.
* guix/scripts/environment.scm (%default-options): Add
'print-extended-build-trace?'.
(guix-environment): Wrap body in 'with-status-report'.
* guix/scripts/pack.scm (%default-options): Add 'print-build-trace?' and
'print-extended-build-trace?'.
(guix-pack): Wrap body in 'with-status-report'.
* guix/scripts/package.scm (%default-options, guix-package): Likewise.
* guix/scripts/system.scm (%default-options, guix-system): Likewise.
* guix/scripts/pull.scm (%default-options, guix-pull): Likewise.
* guix/scripts/substitute.scm (progress-report-port): Don't call STOP
when TOTAL is zero.
(process-substitution): Add #:print-build-trace? and honor it.
(guix-substitute)[print-build-trace?]: New variable.
Pass #:print-build-trace? to 'process-substitution'.
* guix/status.scm: New file.
* guix/store.scm (set-build-options): Add #:print-extended-build-trace?;
pass it into PAIRS.
(%protocol-version): Bump.
(protocol-version, nix-server-version): New procedures.
(current-store-protocol-version): New variable.
(with-store, build-things): Parameterize it.
* guix/ui.scm (build-output-port): Remove.
(colorize-string): Export.
* po/guix/POTFILES.in: Add guix/status.scm.
* tests/status.scm: New file.
* Makefile.am (SCM_TESTS): Add it.
* nix/libstore/worker-protocol.hh (PROTOCOL_VERSION): Bump to 0x162.
* nix/libstore/build.cc (DerivationGoal::registerOutputs)
(SubstitutionGoal::finished): Print a "@ hash-mismatch" trace before
throwing.

1 files changed, 1 insertions, 121 deletions

diff --git a/guix/ui.scm b/guix/ui.scm
index c55ae7e2f8..96f403acf5 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -119,7 +119,7 @@
             warning
             info
             guix-main
-            build-output-port))
+            colorize-string))
 
 ;;; Commentary:
 ;;;
@@ -1676,124 +1676,4 @@ be reset such that subsequent output will not have any colors in effect."
    str
    (color 'RESET)))
 
-(define* (build-output-port #:key
-                            (colorize? #t)
-                            verbose?
-                            (port (current-error-port)))
-  "Return a soft port that processes build output.  By default it colorizes
-phase announcements and replaces any other output with a spinner."
-  (define spun? #f)
-  (define spin!
-    (let ((steps (circular-list "\\" "|" "/" "-")))
-      (lambda ()
-        (match steps
-          ((first . rest)
-           (set! steps rest)
-           (set! spun? #t) ; remember to erase spinner
-           first)))))
-
-  (define use-color?
-    (and colorize?
-         (not (or (getenv "NO_COLOR")
-                  (getenv "INSIDE_EMACS")
-                  (not (isatty? port))))))
-
-  (define handle-string
-    (let* ((proc (if use-color?
-                     colorize-string
-                     (lambda (s . _) s)))
-           (rules `(("^(@ build-started) (.*) (.*)"
-                     #:transform
-                     ,(lambda (m)
-                        (string-append
-                         (proc "Building " 'BLUE 'BOLD)
-                         (match:substring m 2) "\n")))
-                    ,(if verbose?
-                         ;; Err on the side of caution: show everything, even
-                         ;; if it might be redundant.
-                         `("^(@ build-failed)(.+)"
-                           #:transform
-                           ,(lambda (m)
-                              (string-append
-                               (proc "Build failed: " 'RED 'BOLD)
-                               (match:substring m 2))))
-                         ;; Show only that the build failed.
-                         `("^(@ build-failed)(.+) -.*"
-                           #:transform
-                           ,(lambda (m)
-                              (string-append
-                               (proc "Build failed: " 'RED 'BOLD)
-                               (match:substring m 2)
-                               "\n"))))
-                    ;; NOTE: this line contains "\n" characters.
-                    ("^(sha256 hash mismatch for output path)(.*)"
-                     RED BLACK)
-                    ("^(@ build-succeeded) (.*) (.*)"
-                     #:transform
-                     ,(lambda (m)
-                        (string-append
-                         (proc "Built " 'GREEN 'BOLD)
-                         (match:substring m 2) "\n")))
-                    ("^(@ substituter-started) (.*) (.*)"
-                     #:transform
-                     ,(lambda (m)
-                        (string-append
-                         (proc "Substituting " 'BLUE 'BOLD)
-                         (match:substring m 2) "\n")))
-                    ("^(@ substituter-failed) (.*) (.*) (.*)"
-                     #:transform
-                     ,(lambda (m)
-                        (string-append
-                         (proc "Substituter failed: " 'RED 'BOLD)
-                         (match:substring m 2) "\n"
-                         (match:substring m 3) ": "
-                         (match:substring m 4) "\n")))
-                    ("^(@ substituter-succeeded) (.*)"
-                     #:transform
-                     ,(lambda (m)
-                        (string-append
-                         (proc "Substituted " 'GREEN 'BOLD)
-                         (match:substring m 2) "\n")))
-                    ("^(starting phase )(.*)"
-                     BLUE GREEN)
-                    ("^(phase)(.*)(succeeded after)(.*)(seconds)(.*)"
-                     GREEN BLUE GREEN BLUE GREEN BLUE)
-                    ("^(phase)(.*)(failed after)(.*)(seconds)(.*)"
-                     RED BLUE RED BLUE RED BLUE))))
-      (lambda (str)
-        (let ((processed
-               (any (match-lambda
-                      ((pattern #:transform transform)
-                       (and=> (string-match pattern str)
-                              transform))
-                      ((pattern . colors)
-                       (and=> (string-match pattern str)
-                              (lambda (m)
-                                (let ((substrings
-                                       (map (cut match:substring m <>)
-                                            (iota (- (match:count m) 1) 1))))
-                                  (string-join (map proc substrings colors) ""))))))
-                    rules)))
-          (when spun?
-            (display (string #\backspace) port))
-          (if processed
-              (begin
-                (display processed port)
-                (set! spun? #f))
-              ;; Print unprocessed line, or replace with spinner
-              (display (if verbose? str (spin!)) port))))))
-  (make-soft-port
-   (vector
-    ;; procedure accepting one character for output
-    (cut write <> port)
-    ;; procedure accepting a string for output
-    handle-string
-    ;; thunk for flushing output
-    (lambda () (force-output port))
-    ;; thunk for getting one character
-    (const #t)
-    ;; thunk for closing port (not by garbage collection)
-    (lambda () (close port)))
-   "w"))
-
 ;;; ui.scm ends here