;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of GNU Guix.
(define-module (guix status)
#:use-module (guix records)
#:use-module (guix i18n)
- #:use-module ((guix ui) #:select (colorize-string))
+ #:use-module (guix colors)
#:use-module (guix progress)
#:autoload (guix build syscalls) (terminal-columns)
- #:use-module ((guix build download)
- #:select (nar-uri-abbreviation))
+ #:autoload (guix build download) (nar-uri-abbreviation)
#:use-module (guix store)
#:use-module (guix derivations)
#:use-module (guix memoization)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
#:use-module (ice-9 regex)
build
build-derivation
build-system
+ build-log-file
+ build-phase
+ build-completion
download?
download
(default '())))
;; On-going or completed build.
-(define-record-type <build>
- (%build derivation id system log-file completion)
+(define-immutable-record-type <build>
+ (%build derivation id system log-file phase completion)
build?
(derivation build-derivation) ;string (.drv file name)
(id build-id) ;#f | integer
(system build-system) ;string
(log-file build-log-file) ;#f | string
- (completion build-completion)) ;#f | integer (percentage)
+ (phase build-phase ;#f | symbol
+ set-build-phase)
+ (completion build-completion ;#f | integer (percentage)
+ set-build-completion))
-(define* (build derivation system #:key id log-file completion)
+(define* (build derivation system #:key id log-file phase completion)
"Return a new build."
- (%build derivation id system log-file completion))
+ (%build derivation id system log-file phase completion))
;; On-going or completed downloads. Downloads can be stem from substitutes
;; and from "builtin:download" fixed-output derivations.
(lambda (download)
(string=? item (download-item download))))
+(define %phase-start-rx
+ ;; Match the "starting phase" message emitted by 'gnu-build-system'.
+ (make-regexp "^starting phase [`']([^']+)'"))
+
(define %percentage-line-rx
;; Things like CMake write lines like "[ 10%] gcc -c …". This regexp
;; matches them.
(define (update-build status id line)
"Update STATUS based on LINE, a build output line for ID that might contain
a completion indication."
- (define (set-completion b %)
- (build (build-derivation b)
- (build-system b)
- #:id (build-id b)
- #:log-file (build-log-file b)
- #:completion %))
-
(define (find-build)
(find (lambda (build)
(and (build-id build)
(let ((build (find-build)))
(build-status
(inherit status)
- (building (cons (set-completion build %)
+ (building (cons (set-build-completion build %)
(delq build (build-status-building status)))))))
(cond ((string-any #\nul line)
(let ((done (string->number (match:substring match 1)))
(total (string->number (match:substring match 3))))
(update (* 100. (/ done total))))))
+ ((regexp-exec %phase-start-rx line)
+ =>
+ (lambda (match)
+ (let ((phase (match:substring match 1))
+ (build (find-build)))
+ (if build
+ (build-status
+ (inherit status)
+ (building
+ (cons (set-build-phase (set-build-completion build #f)
+ (string->symbol phase))
+ (delq build (build-status-building status)))))
+ status))))
(else
status)))
(and (current-store-protocol-version)
(>= (current-store-protocol-version) #x163)))
-(define isatty?*
- (mlambdaq (port)
- (isatty? port)))
-
(define spin!
(let ((steps (circular-list "\\" "|" "/" "-")))
- (lambda (port)
- "Display a spinner on PORT."
+ (lambda (phase port)
+ "Display a spinner on PORT. If PHASE is true, display it as a hint of
+the current build phase."
(when (isatty?* port)
(match steps
((first . rest)
(set! steps rest)
(display "\r\x1b[K" port)
(display first port)
+ (when phase
+ (display " " port)
+ ;; TRANSLATORS: The word "phase" here denotes a "build phase";
+ ;; "~a" is a placeholder for the untranslated name of the current
+ ;; build phase--e.g., 'configure' or 'build'.
+ (format port (G_ "'~a' phase") phase))
(force-output port)))))))
-(define (color-output? port)
- "Return true if we should write colored output to PORT."
- (and (not (getenv "INSIDE_EMACS"))
- (not (getenv "NO_COLOR"))
- (isatty?* port)))
-
-(define-syntax color-rules
- (syntax-rules ()
- "Return a procedure that colorizes the string it is passed according to
-the given rules. Each rule has the form:
-
- (REGEXP COLOR1 COLOR2 ...)
-
-where COLOR1 specifies how to colorize the first submatch of REGEXP, and so
-on."
- ((_ (regexp colors ...) rest ...)
- (let ((next (color-rules rest ...))
- (rx (make-regexp regexp)))
- (lambda (str)
- (if (string-index str #\nul)
- str
- (match (regexp-exec rx str)
- (#f (next str))
- (m (let loop ((n 1)
- (c '(colors ...))
- (result '()))
- (match c
- (()
- (string-concatenate-reverse result))
- ((first . tail)
- (loop (+ n 1) tail
- (cons (colorize-string (match:substring m n)
- first)
- result)))))))))))
- ((_)
- (lambda (str)
- str))))
-
(define colorize-log-line
;; Take a string and return a possibly colorized string according to the
;; rules below.
#:optional (port (current-error-port))
#:key
(colorize? (color-output? port))
+ (print-urls? #t)
(print-log? #t))
"Print information about EVENT and STATUS to PORT. When COLORIZE? is true,
produce colorful output. When PRINT-LOG? is true, display the build log in
-addition to build events."
+addition to build events. When PRINT-URLS? is true, display the URL of
+substitutes being downloaded."
(define info
(if colorize?
- (cut colorize-string <> 'BOLD)
+ (cute colorize-string <> (color BOLD))
identity))
(define success
(if colorize?
- (cut colorize-string <> 'GREEN 'BOLD)
+ (cute colorize-string <> (color GREEN BOLD))
identity))
(define failure
(if colorize?
- (cut colorize-string <> 'RED 'BOLD)
+ (cute colorize-string <> (color RED BOLD))
identity))
- (define (report-build-progress %)
+ (define tty?
+ (isatty?* port))
+
+ (define (report-build-progress phase %)
(let ((% (min (max % 0) 100))) ;sanitize
(erase-current-line port)
- (format port "~3d% " (inexact->exact (round %)))
- (display (progress-bar % (- (current-terminal-columns) 5))
- port)
+ (let* ((prefix (format #f "~3d% ~@['~a' ~]"
+ (inexact->exact (round %))
+ (case phase
+ ((build) #f) ;not useful to display it
+ (else phase))))
+ (length (string-length prefix)))
+ (display prefix port)
+ (display (progress-bar % (- (current-terminal-columns) length))
+ port))
(force-output port)))
(define print-log-line
(match (build-status-building status)
((build) ;single job
(match (build-completion build)
- ((? number? %) (report-build-progress %))
- (_ (spin! port))))
+ ((? number? %)
+ (report-build-progress (build-phase build) %))
+ (_
+ (spin! (build-phase build) port))))
(_
- (spin! port))))))
+ (spin! #f port))))))
+
+ (define erase-current-line*
+ (if (and (not print-log?) (isatty?* port))
+ (lambda ()
+ (erase-current-line port)
+ (force-output port))
+ (const #t)))
- (unless print-log?
- (display "\r" port)) ;erase the spinner
(match event
(('build-started drv . _)
+ (erase-current-line*)
(let ((properties (derivation-properties
(read-derivation-from-file drv))))
(match (assq-ref properties 'type)
(let ((count (match (assq-ref properties 'graft)
(#f 0)
(lst (or (assq-ref lst 'count) 0)))))
- (format port (info (N_ "applying ~a graft for ~a..."
- "applying ~a grafts for ~a..."
+ (format port (info (N_ "applying ~a graft for ~a ..."
+ "applying ~a grafts for ~a ..."
count))
count drv)))
+ ('profile
+ (let ((count (match (assq-ref properties 'profile)
+ (#f 0)
+ (lst (or (assq-ref lst 'count) 0)))))
+ (format port (info (N_ "building profile with ~a package..."
+ "building profile with ~a packages..."
+ count))
+ count)))
('profile-hook
(let ((hook-type (assq-ref properties 'hook)))
(or (and=> (hook-message hook-type)
(format port (info (G_ "building ~a...")) drv))))
(newline port))
(('build-succeeded drv . _)
+ (erase-current-line*) ;erase spinner or progress bar
(when (or print-log? (not (extended-build-trace-supported?)))
(format port (success (G_ "successfully built ~a")) drv)
(newline port))
(length ongoing))
(map build-derivation ongoing)))))
(('build-failed drv . _)
+ (erase-current-line*) ;erase spinner or progress bar
(format port (failure (G_ "build of ~a failed")) drv)
(newline port)
(match (derivation-log-file drv)
(format port (info (G_ "View build log at '~a'.")) log)))
(newline port))
(('substituter-started item _ ...)
+ (erase-current-line*)
(when (or print-log? (not (extended-build-trace-supported?)))
(format port (info (G_ "substituting ~a...")) item)
(newline port)))
(('download-started item uri _ ...)
- (format port (info (G_ "downloading from ~a...")) uri)
- (newline port))
+ (when print-urls?
+ (erase-current-line*)
+ (format port (info (G_ "downloading from ~a ...")) uri)
+ (newline port)))
(('download-progress item uri
(= string->number size)
(= string->number transferred))
(nar-uri-abbreviation uri)
(basename uri))))
(display-download-progress uri size
+ #:tty? tty?
#:start-time
(download-start download)
#:transferred transferred))))))
(colorize? (color-output? port)))
(print-build-event event old-status status port
#:colorize? colorize?
+ #:print-urls? #f
+ #:print-log? #f))
+
+(define* (print-build-event/quiet-with-urls event old-status status
+ #:optional
+ (port (current-error-port))
+ #:key
+ (colorize? (color-output? port)))
+ (print-build-event event old-status status port
+ #:colorize? colorize?
+ #:print-urls? #t ;show download URLs
#:print-log? #f))
(define* (build-status-updater #:optional (on-change (const #t)))
"Return the logging procedure that corresponds to LEVEL."
(cond ((<= level 0) (const #t))
((= level 1) print-build-event/quiet)
+ ((= level 2) print-build-event/quiet-with-urls)
(else print-build-event)))
(define (call-with-status-verbosity level thunk)
HCoop / jackhill / guix / guix.git / blobdiff