From dc0f74e5fc26977a3ee6c4f2aa74a141f4359982 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 18 Jan 2017 23:21:29 +0100 Subject: 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. --- guix/ui.scm | 122 +----------------------------------------------------------- 1 file changed, 1 insertion(+), 121 deletions(-) (limited to 'guix/ui.scm') 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 -- cgit v1.2.3