[bug#32634] [PATCH 2/2] ui: Add soft port for styling and filtering build output.

[Ricardo Wurmus]

* 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 <address@hidden>
---
 guix/scripts/build.scm   |   2 +-
 guix/scripts/package.scm |  39 ++++++++------
 guix/ui.scm              | 109 ++++++++++++++++++++++++++++++++++++++-
 3 files changed, 132 insertions(+), 18 deletions(-)

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 <address@hidden>
 ;;; Copyright © 2013, 2014 Free Software Foundation, Inc.
 ;;; Copyright © 2018 Sahithi Yarlagadda <address@hidden>
+;;; Copyright © 2018 Ricardo Wurmus <address@hidden>
 ;;;
 ;;; 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