* guix/ui.scm (build-output-port): New procedure.
* guix/scripts/package.scm (%default-options): Print build trace.
(guix-package): Use build-output-port.
* guix/scripts/build.scm (guix-build): Use build-output-port.
Co-authored-by: Sahithi Yarlagadda <sahi@swecha.net>
---
guix/scripts/build.scm | 2 +-
guix/scripts/package.scm | 39 ++++++++------
guix/ui.scm | 109 ++++++++++++++++++++++++++++++++++++++-
3 files changed, 132 insertions(+), 18 deletions(-)
Toggle diff (201 lines)
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 4dd4fbccd..3fa3c2c20 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 b38a55d01..216b63049 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -328,7 +328,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]...
@@ -883,18 +884,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 f8f2cad69..5482d919b 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -12,6 +12,7 @@
;;; 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.
;;;
@@ -118,7 +119,7 @@
warning
info
guix-main
- colorize-string))
+ build-output-port))
;;; Commentary:
;;;
@@ -1675,4 +1676,110 @@ 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 ((rules `(("^(@ build-started) (.*) (.*)"
+ #:transform
+ ,(lambda (m)
+ (string-append
+ (colorize-string "Building " 'BLUE 'BOLD)
+ (match:substring m 2) "\n")))
+ ("^(@ build-failed) (.*) (.*)"
+ #:transform
+ ,(lambda (m)
+ (string-append
+ (colorize-string "Build failed: " 'RED 'BOLD)
+ (match:substring m 2) "\n")))
+ ("^(@ build-succeeded) (.*) (.*)"
+ #:transform
+ ,(lambda (m)
+ (string-append
+ (colorize-string "Built " 'GREEN 'BOLD)
+ (match:substring m 2) "\n")))
+ ("^(@ substituter-started) (.*) (.*)"
+ #:transform
+ ,(lambda (m)
+ (string-append
+ (colorize-string "Substituting " 'RED 'BOLD)
+ (match:substring m 2) "\n")))
+ ("^(@ substituter-failed) (.*) (.*) (.*)"
+ #:transform
+ ,(lambda (m)
+ (string-append
+ (colorize-string "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
+ (colorize-string "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)))
+ (proc (if use-color?
+ colorize-string
+ (lambda (s _) s))))
+ (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
--
2.18.0
