diff options
Diffstat (limited to 'guix')
-rw-r--r-- | guix/scripts/build.scm | 2 | ||||
-rw-r--r-- | guix/scripts/package.scm | 39 | ||||
-rw-r--r-- | guix/ui.scm | 162 |
3 files changed, 185 insertions, 18 deletions
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 4dd4fbccdf..3fa3c2c20f 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -735,7 +735,7 @@ needed." (parameterize ((current-build-output-port (if quiet? (%make-void-port "w") - (current-error-port)))) + (build-output-port #:verbose? #t)))) (let* ((mode (assoc-ref opts 'build-mode)) (drv (options->derivations store opts)) (urls (map (cut string-append <> "/log") diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 97bcc699d9..73cbccba3b 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -329,7 +329,8 @@ ENTRIES, a list of manifest entries, in the context of PROFILE." `((verbosity . 0) (graft? . #t) (substitutes? . #t) - (build-hook? . #t))) + (build-hook? . #t) + (print-build-trace? . #t))) (define (show-help) (display (G_ "Usage: guix package [OPTION]... @@ -930,18 +931,24 @@ processed, #f otherwise." (arg-handler arg result) (leave (G_ "~A: extraneous argument~%") arg))) - (let ((opts (parse-command-line args %options (list %default-options #f) - #:argument-handler handle-argument))) - (with-error-handling - (or (process-query opts) - (parameterize ((%store (open-connection)) - (%graft? (assoc-ref opts 'graft?))) - (set-build-options-from-command-line (%store) opts) - - (parameterize ((%guile-for-build - (package-derivation - (%store) - (if (assoc-ref opts 'bootstrap?) - %bootstrap-guile - (canonical-package guile-2.2))))) - (process-actions (%store) opts))))))) + (define opts + (parse-command-line args %options (list %default-options #f) + #:argument-handler handle-argument)) + (define verbose? + (assoc-ref opts 'verbose?)) + + (with-error-handling + (or (process-query opts) + (parameterize ((%store (open-connection)) + (%graft? (assoc-ref opts 'graft?))) + (set-build-options-from-command-line (%store) opts) + + (parameterize ((%guile-for-build + (package-derivation + (%store) + (if (assoc-ref opts 'bootstrap?) + %bootstrap-guile + (canonical-package guile-2.2)))) + (current-build-output-port + (build-output-port #:verbose? verbose?))) + (process-actions (%store) opts)))))) diff --git a/guix/ui.scm b/guix/ui.scm index 29c0b2b9ce..1bbd37c255 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -10,6 +10,9 @@ ;;; Copyright © 2016 Roel Janssen <roel@gnu.org> ;;; Copyright © 2016 Benz Schenk <benz.schenk@uzh.ch> ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com> +;;; Copyright © 2013, 2014 Free Software Foundation, Inc. +;;; Copyright © 2018 Sahithi Yarlagadda <sahi@swecha.net> +;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -115,7 +118,8 @@ guix-warning-port warning info - guix-main)) + guix-main + build-output-port)) ;;; Commentary: ;;; @@ -1622,4 +1626,160 @@ and signal handling has already been set up." (initialize-guix) (apply run-guix args)) +(define color-table + `((CLEAR . "0") + (RESET . "0") + (BOLD . "1") + (DARK . "2") + (UNDERLINE . "4") + (UNDERSCORE . "4") + (BLINK . "5") + (REVERSE . "6") + (CONCEALED . "8") + (BLACK . "30") + (RED . "31") + (GREEN . "32") + (YELLOW . "33") + (BLUE . "34") + (MAGENTA . "35") + (CYAN . "36") + (WHITE . "37") + (ON-BLACK . "40") + (ON-RED . "41") + (ON-GREEN . "42") + (ON-YELLOW . "43") + (ON-BLUE . "44") + (ON-MAGENTA . "45") + (ON-CYAN . "46") + (ON-WHITE . "47"))) + +(define (color . lst) + "Return a string containing the ANSI escape sequence for producing the +requested set of attributes in LST. Unknown attributes are ignored." + (let ((color-list + (remove not + (map (lambda (color) (assq-ref color-table color)) + lst)))) + (if (null? color-list) + "" + (string-append + (string #\esc #\[) + (string-join color-list ";" 'infix) + "m")))) + +(define (colorize-string str . color-list) + "Return a copy of STR colorized using ANSI escape sequences according to the +attributes STR. At the end of the returned string, the color attributes will +be reset such that subsequent output will not have any colors in effect." + (string-append + (apply color color-list) + 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"))) + ("^(@ build-failed) (.*) (.*)" + #:transform + ,(lambda (m) + (string-append + (proc "Build failed: " 'RED 'BOLD) + (match:substring m 2) "\n"))) + ("^(@ 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 |