;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2018, 2019, 2020 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)
(and (current-store-protocol-version)
(>= (current-store-protocol-version) #x163)))
-(define isatty?*
- (mlambdaq (port)
- (isatty? port)))
-
(define spin!
(let ((steps (circular-list "\\" "|" "/" "-")))
(lambda (phase port)
(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.
addition to build events."
(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 phase %)
(spin! #f port))))))
(define erase-current-line*
- (if (isatty?* port)
- (lambda (port)
+ (if (and (not print-log?) (isatty?* port))
+ (lambda ()
(erase-current-line port)
(force-output port))
(const #t)))
- (unless print-log?
- (erase-current-line* port)) ;clear the spinner or progress bar
(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)
+ (erase-current-line*)
+ (format port (info (G_ "downloading from ~a ...")) uri)
(newline port))
(('download-progress item uri
(= string->number size)