rekahsoft
/
guix
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

ui: Add soft port for styling and filtering build output. 

* 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>
This commit is contained in:
Ricardo Wurmus 2018-09-04 17:32:27 +02:00
parent 80ec1b73d2
commit 15cc7e6adf
No known key found for this signature in database
GPG Key ID: 197A5888235FACAC
3 changed files with 131 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
guix/scripts/build.scm
View File

@ -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")

37
guix/scripts/package.scm
View File

@ -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)
(define opts
(parse-command-line args %options (list %default-options #f)
#:argument-handler handle-argument))
(define verbose?
(assoc-ref opts 'verbose?))
(parameterize ((%guile-for-build
(package-derivation
(%store)
(if (assoc-ref opts 'bootstrap?)
%bootstrap-guile
(canonical-package guile-2.2)))))
(process-actions (%store) opts)))))))
(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))))))

109
guix/ui.scm
View File

@ -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* ((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