From c40fc712dec93299657e916907bc603d30178327 Mon Sep 17 00:00:00 2001
Message-Id: <c40fc712dec93299657e916907bc603d30178327.1672338241.git.julien@lepiller.eu>
From: Julien Lepiller <julien@lepiller.eu>
Date: Thu, 29 Dec 2022 19:20:34 +0100
Subject: [PATCH] guix: Support showing status in parallel.

* guix/status.scm (build-status): Add `last-daemon-line` field.
(build): Add `last-line` and `start` fields.
(update-build): Record partial lines (not ending with \n) in the
last-line field of the new build or status record.
(print-build-event): Always print status of all current builds and
downloads at the end.  Update all status lines.
---
 guix/status.scm | 358 +++++++++++++++++++++++++++++++++---------------
 1 file changed, 245 insertions(+), 113 deletions(-)

diff --git a/guix/status.scm b/guix/status.scm
index 2c69f49fb5..5eb3ebc46b 100644
--- a/guix/status.scm
+++ b/guix/status.scm
@@ -49,6 +49,7 @@ (define-module (guix status)
             build-status-downloading
             build-status-builds-completed
             build-status-downloads-completed
+            build-status-last-daemon-line
 
             build?
             build
@@ -57,6 +58,8 @@ (define-module (guix status)
             build-log-file
             build-phase
             build-completion
+            build-start
+            build-last-line
 
             download?
             download
@@ -100,11 +103,13 @@ (define-record-type* <build-status> build-status make-build-status
   (builds-completed build-status-builds-completed ;list of <build>
                     (default '()))
   (downloads-completed build-status-downloads-completed ;list of <download>
-                       (default '())))
+                       (default '()))
+  (last-daemon-line build-status-last-daemon-line ;string
+                    (default "")))
 
 ;; On-going or completed build.
 (define-immutable-record-type <build>
-  (%build derivation id system log-file phase completion)
+  (%build derivation id system log-file phase completion start last-line)
   build?
   (derivation  build-derivation)                ;string (.drv file name)
   (id          build-id)                        ;#f | integer
@@ -113,11 +118,17 @@ (define-immutable-record-type <build>
   (phase       build-phase                      ;#f | symbol
                set-build-phase)
   (completion  build-completion                 ;#f | integer (percentage)
-               set-build-completion))
+               set-build-completion)
+  (start       build-start                      ;<time>
+               set-build-start)
+  (last-line   build-last-line                  ;#f | string
+               set-build-last-line))
 
-(define* (build derivation system #:key id log-file phase completion)
+(define* (build derivation system #:key id log-file phase completion
+                (start (current-time time-monotonic))
+                (last-line ""))
   "Return a new build."
-  (%build derivation id system log-file phase completion))
+  (%build derivation id system log-file phase completion start last-line))
 
 ;; On-going or completed downloads.  Downloads can be stem from substitutes
 ;; and from "builtin:download" fixed-output derivations.
@@ -166,6 +177,12 @@ (define %fraction-line-rx
 (define (update-build status id line)
   "Update STATUS based on LINE, a build output line for ID that might contain
 a completion indication."
+  (define (last-line str)
+    (last (string-split str #\newline)))
+
+  (define (update-last-line build)
+    (set-build-last-line build (last-line (string-append (build-last-line build) line))))
+
   (define (find-build)
     (find (lambda (build)
             (and (build-id build)
@@ -173,15 +190,27 @@ (define (update-build status id line)
           (build-status-building status)))
 
   (define (update %)
-    (let ((build (find-build)))
+    (let ((build (find-build))
+          (new-build (update-last-line (find-build))))
       (build-status
        (inherit status)
-       (building (cons (set-build-completion build %)
+       (building (cons (set-build-completion new-build %)
                        (delq build (build-status-building status)))))))
 
-  (cond ((string-any #\nul line)
+  (cond ((not id)
+         (build-status
+           (inherit status)
+           (last-daemon-line (string-append (build-status-last-daemon-line status) line))))
+        ((string-any #\nul line)
          ;; Don't try to match a regexp here.
-         status)
+         (let ((build (find-build)))
+           (if build
+               (build-status
+                 (inherit status)
+                 (building
+                   (cons (update-last-line build)
+                         (delq build (build-status-building status)))))
+               status)))
         ((regexp-exec %percentage-line-rx line)
          =>
          (lambda (match)
@@ -202,12 +231,20 @@ (define (update-build status id line)
                  (build-status
                   (inherit status)
                   (building
-                   (cons (set-build-phase (set-build-completion build #f)
-                                          (string->symbol phase))
+                   (cons (update-last-line
+                           (set-build-phase (set-build-completion build #f)
+                                            (string->symbol phase)))
                          (delq build (build-status-building status)))))
                  status))))
         (else
-         status)))
+         (let ((build (find-build)))
+           (if build
+               (build-status
+                 (inherit status)
+                 (building
+                   (cons (update-last-line build)
+                         (delq build (build-status-building status)))))
+               status)))))
 
 (define* (compute-status event status
                          #:key
@@ -436,48 +473,170 @@ (define* (print-build-event event old-status status
   (define tty?
     (isatty?* port))
 
-  (define (report-build-progress phase %)
-    (let ((% (min (max % 0) 100)))                ;sanitize
-      (erase-current-line 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 (report-build-progress name phase %)
+    (if %
+      (let ((% (min (max % 0) 100)))                ;sanitize
+        (erase-current-line port)
+        (let* ((prefix (format #f "~a ~3d% ~@['~a' ~]"
+                               (string-join (cdr (string-split (basename name) #\-)) "-")
+                               (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)
+          (newline port)))
+      (erase-format port "~a…~%" name))
+    (force-output port))
+
+  (define (find-build id status)
+    (find
+      (lambda (build)
+        (and id (build-id build)
+             (= (build-id build) id)))
+      (build-status-building status)))
+
+  (define (get-line id line)
+    (define (remove-last lst)
+      (match lst
+        (() '())
+        ((_) '())
+        ((e lst ...) (cons e (remove-last lst)))))
+
+    (let ((old-build (find-build id old-status)))
+      (cond
+        ((not id)
+         (let ((commited-lines
+                 (remove-last
+                   (string-split (string-append (build-status-last-daemon-line old-status) line)
+                                 #\newline))))
+           (if (null? commited-lines)
+               ""
+               (string-append (string-join commited-lines "\n") "\n"))))
+        (old-build
+          (let ((commited-lines
+                  (remove-last
+                    (string-split (string-append (build-last-line old-build) line)
+                                  #\newline))))
+            (if (null? commited-lines)
+                ""
+                (string-append (string-join commited-lines "\n") "\n"))))
+        (else line))))
 
   (define print-log-line
-    (if print-log?
-        (if colorize?
-            (lambda (id line)
-              (display (colorize-log-line line) port))
-            (lambda (id line)
-              (display line port)))
-        (lambda (id line)
-          (match (build-status-building status)
-            ((build)                              ;single job
-             (match (build-completion build)
-               ((? number? %)
-                (report-build-progress (build-phase build) %))
-               (_
-                (spin! (build-phase build) port))))
-            (_
-             (spin! #f port))))))
+    (lambda (id line)
+      (print-log-line* (get-line id line))))
+
+  (define (print-log-line* line)
+    (define (print-lines lines)
+      (match lines
+        ((line) (print-line line))
+        ((line lines ...)
+         (print-line (string-append line "\n")))))
+
+    (define (print-line line)
+      (erase-current-line*)
+      (if colorize?
+          (display (colorize-log-line line) port)
+          (display line port)))
+
+    (when print-log?
+      (print-lines (string-split line #\newline))))
 
   (define erase-current-line*
-    (if (and (not print-log?) (isatty?* port))
+    (if (isatty?* port)
         (lambda ()
           (erase-current-line port)
           (force-output port))
         (const #t)))
 
+  (define (go-back n)
+    (when (and (isatty?* port) (> n 0))
+      (format port "\r\x1b[~dA" n)))
+
+  (define (build<? build1 build2)
+    (match (list (build-start build1) (build-start build2))
+      ((#f #f) (string<? (build-derivation build1) (build-derivation build2)))
+      ((_ #f) #t)
+      ((#f _) #f)
+      ((t1 t2) (time<? t1 t2))))
+
+  (define (download<? download1 download2)
+    (match (list (download-start download1) (download-start download2))
+      ((#f #f) (string<? (download-uri download1) (download-uri download2)))
+      ((_ #f) #t)
+      ((#f _) #f)
+      ((t1 t2) (time<? t1 t2))))
+
+  (define (print-progress)
+    (unless (string-null? (build-status-last-daemon-line status))
+      (pk 'daemon-partial (build-status-last-daemon-line status))
+      #;(erase-current-line*)
+      #;(print-log-line* (build-status-last-daemon-line status))
+      #;(newline port))
+
+    (when print-log?
+      (for-each
+        (lambda (build)
+          (unless (or (not (build-last-line build))
+                      (string-null? (build-last-line build)))
+            (erase-current-line*)
+            (print-log-line* (build-last-line build))
+            (newline port)))
+        (sort (build-status-building status)
+              build<?)))
+
+    (for-each
+      (lambda (build)
+        (report-build-progress (build-derivation build) (build-phase build)
+                               (build-completion build)))
+      (sort (build-status-building status)
+            build<?))
+    (for-each
+      (lambda (download)
+        (let ((uri (if (string-contains (download-uri download) "/nar/")
+                       (nar-uri-abbreviation (download-uri download))
+                       (basename (download-uri download)))))
+          (display-download-progress uri (download-size download)
+                                     #:tty? tty?
+                                     #:start-time
+                                     (download-start download)
+                                     #:transferred (download-transferred download))
+          (newline port)))
+      (sort (build-status-downloading status)
+            download<?))
+
+    (go-back (+ (length (build-status-building status))
+                (if print-log?
+                    (length (filter
+                              (lambda (build)
+                                (let ((last-line (build-last-line build)))
+                                  (and last-line (not (string-null? last-line)))))
+                              (build-status-building status)))
+                    0)
+                (length (build-status-downloading status))
+                (if (string-null? (build-status-last-daemon-line status)) 0 1)))
+    (force-output port))
+
+  (define* (erase-format port msg . args)
+    (define (print-lines lines)
+      (match lines
+        (() #t)
+        ((line)
+         (erase-current-line*)
+         (format port line))
+        ((line lines ...)
+         (erase-current-line*)
+         (format port line)
+         (newline port)
+         (print-lines lines))))
+    (let ((str (apply format #f msg args)))
+      (print-lines (string-split str #\newline))))
+
   (match event
     (('build-started drv . _)
-     (erase-current-line*)
      (let ((properties (derivation-properties
                         (read-derivation-from-file drv))))
        (match (assq-ref properties 'type)
@@ -485,120 +644,91 @@ (define* (print-build-event event old-status status
            (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 ..."
-                                    count))
-                     count
-                     (string-drop-right (store-path-package-name drv)
-                                        (string-length ".drv")))))
+             (erase-format port (info (N_ "applying ~a graft for ~a ..."
+                                      "applying ~a grafts for ~a ..."
+                                      count))
+                           count
+                           (string-drop-right (store-path-package-name drv)
+                                              (string-length ".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)))
+            (erase-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)
                        (lambda (msg)
                          (display (info msg) port)))
-                (format port (info (G_ "running profile hook of type '~a'..."))
-                        hook-type))))
+                (erase-format port (info (G_ "running profile hook of type '~a'..."))
+                              hook-type))))
          (_
-          (format port (info (G_ "building ~a...")) drv))))
-     (newline port))
+          (erase-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))
-     (match (build-status-building status)
-       (() #t)
-       (ongoing                                   ;when max-jobs > 1
-        (format port
-                (N_ "The following build is still in progress:~%~{  ~a~%~}~%"
-                    "The following builds are still in progress:~%~{  ~a~%~}~%"
-                    (length ongoing))
-                (map build-derivation ongoing)))))
+       (erase-format port (success (G_ "successfully built ~a")) drv)
+       (newline port)))
     (('build-failed drv . _)
-     (erase-current-line*)                      ;erase spinner or progress bar
-     (format port (failure (G_ "build of ~a failed")) drv)
+     (erase-format port (failure (G_ "build of ~a failed")) drv)
      (newline port)
      (match (derivation-log-file drv)
        (#f
-        (format port (failure (G_ "Could not find build log for '~a'."))
-                drv))
+        (erase-format port (failure (G_ "Could not find build log for '~a'."))
+                      drv)
+        (newline port))
        (log
-        (format port (emph (G_ "View build log at '~a'.")) log)))
-     (newline port))
+        (erase-format port (emph (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)
+       (erase-format port (info (G_ "substituting ~a...")) item)
        (newline port)))
     (('download-started item uri _ ...)
      (when print-urls?
-       (erase-current-line*)
-       (format port (info (G_ "downloading from ~a ...")) uri)
+       (erase-format port (info (G_ "downloading from ~a ...")) uri)
        (newline port)))
     (('download-progress item uri
                          (= string->number size)
                          (= string->number transferred))
-     ;; Print a progress bar, but only if there's only one on-going
-     ;; job--otherwise the output would be intermingled.
-     (when (= 1 (simultaneous-jobs status))
-       (match (find (matching-download item)
-                    (build-status-downloading status))
-         (#f #f)                                  ;shouldn't happen!
-         (download
-          ;; XXX: It would be nice to memoize the abbreviation.
-          (let ((uri (if (string-contains uri "/nar/")
-                         (nar-uri-abbreviation uri)
-                         (basename uri))))
-            (display-download-progress uri size
-                                       #:tty? tty?
-                                       #:start-time
-                                       (download-start download)
-                                       #:transferred transferred))))))
+     ;; ignore event, since progress is shown after messages
+     event)
     (('substituter-succeeded item _ ...)
      (when (extended-build-trace-supported?)
-       ;; If there are no jobs running, we already reported download completion
-       ;; so there's nothing left to do.
-       (unless (zero? (simultaneous-jobs status))
-         (format port (success (G_ "substitution of ~a complete")) item)
-         (newline port))
-
-       (when (and print-urls? (zero? (simultaneous-jobs status)))
-         ;; Leave a blank line after the "downloading ..." line and the
-         ;; progress bar (that's three lines in total).
-         (newline port))))
+       (erase-format port (success (G_ "substitution of ~a complete")) item)
+       (newline port)))
     (('substituter-failed item _ ...)
-     (format port (failure (G_ "substitution of ~a failed")) item)
+     (erase-format port (failure (G_ "substitution of ~a failed")) item)
      (newline port))
     (('hash-mismatch item algo expected actual _ ...)
      ;; TRANSLATORS: The final string looks like "sha256 hash mismatch for
      ;; /gnu/store/…-sth:", where "sha256" is the hash algorithm.
-     (format port (failure (G_ "~a hash mismatch for ~a:")) algo item)
+     (erase-format port (failure (G_ "~a hash mismatch for ~a:")) algo item)
      (newline port)
-     (format port (emph (G_ "\
+     (erase-format port (emph (G_ "\
   expected hash: ~a
   actual hash:   ~a~%"))
-             expected actual))
+             expected actual)
+     (newline port))
     (('build-remote drv host _ ...)
-     (format port (emph (G_ "offloading build of ~a to '~a'")) drv host)
+     (erase-format port (emph (G_ "offloading build of ~a to '~a'")) drv host)
      (newline port))
     (('build-log pid line)
+     ;(pk 'build-log pid line)
      (if (multiplexed-output-supported?)
          (if (not pid)
              (begin
                ;; LINE comes from the daemon, not from builders.  Let it
-               ;; through.
-               (display line port)
+               ;; through, but only full lines. Partial lines are printed in
+               ;; print-progress
+               (erase-format port (get-line pid line))
                (force-output port))
              (print-log-line pid line))
-         (cond ((string-prefix? "substitute: " line)
+         (print-log-line pid line)
+         #;(cond ((string-prefix? "substitute: " line)
                 ;; The daemon prefixes early messages coming with 'guix
                 ;; substitute' with "substitute:".  These are useful ("updating
                 ;; substitutes from URL"), so let them through.
@@ -612,7 +742,9 @@ (define* (print-build-event event old-status status
                (else
                 (print-log-line pid line)))))
     (_
-     event)))
+     event))
+  
+  (print-progress))
 
 (define* (print-build-event/quiet event old-status status
                                   #:optional
-- 
2.38.1