pull: Add a compilation progress report.

* guix/build/pull.scm (report-build-progress): New procedure.
  (p-for-each): Add #:progress parameter.
  [loop]: Keep track of the number of completed processes.  Tail-call
  PROGRESS at each loop iteration.
  (build-guix): Add #:debug-port parameter.  Use it for verbose
  messages.  Change 'tar' flags to 'xf'.  Around 'compile-file' call,
  bind CURRENT-WARNING-PORT to DEBUG-PORT.
* guix/scripts/pull.scm (unpack): Add #:verbose? parameter.
  [builder]: Pass #:debug-port to 'build-guix'.
  (guix-pull): Leave CURRENT-BUILD-OUTPUT-PORT unchanged.  Pass
  #:verbose? to 'unpack'.

2 files changed, 65 insertions, 31 deletions

diff --git a/guix/build/pull.scm b/guix/build/pull.scm
index e5b8797503..841787f0bb 100644
--- a/guix/build/pull.scm
+++ b/guix/build/pull.scm
@@ -21,6 +21,7 @@
   #:use-module (system base compile)
   #:use-module (ice-9 ftw)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 format)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
@@ -47,43 +48,70 @@ normally, and 1 if an exception is raised."
     (pid
      #t)))
 
+(define* (report-build-progress total completed cont
+                                #:optional (log-port (current-error-port)))
+  "Report that COMPLETED out of TOTAL files have been completed, and call
+CONT."
+  (display #\cr log-port)
+  (format log-port "compiling...\t~5,1f% of ~d files" ;FIXME: i18n
+          (* 100. (/ completed total)) total)
+  (force-output log-port)
+  (cont))
+
 (define* (p-for-each proc lst
-                     #:optional (max-processes (current-processor-count)))
+                     #:optional (max-processes (current-processor-count))
+                     #:key (progress report-build-progress))
   "Invoke PROC for each element of LST in a separate process, using up to
-MAX-PROCESSES processes in parallel.  Raise an error if one of the processes
-exit with non-zero."
+MAX-PROCESSES processes in parallel.  Call PROGRESS at each step, passing it
+the continuation.  Raise an error if one of the processes exit with non-zero."
+  (define total
+    (length lst))
+
   (define (wait-for-one-process)
     (match (waitpid WAIT_ANY)
       ((_ . status)
        (unless (zero? (status:exit-val status))
          (error "process failed" proc status)))))
 
-  (let loop ((lst   lst)
-             (running 0))
+  (let loop ((lst       lst)
+             (running   0)
+             (completed 0))
     (match lst
       (()
        (or (zero? running)
-           (begin
+           (let ((running   (- running 1))
+                 (completed (+ completed 1)))
              (wait-for-one-process)
-             (loop lst (- running 1)))))
+             (progress total completed
+                       (lambda ()
+                         (loop lst running completed))))))
       ((head . tail)
        (if (< running max-processes)
-           (begin
+           (let ((running (+ 1 running)))
              (call-with-process (cut proc head))
-             (loop tail (+ running 1)))
-           (begin
+             (progress total completed
+                       (lambda ()
+                         (loop tail running completed))))
+           (let ((running   (- running 1))
+                 (completed (+ completed 1)))
              (wait-for-one-process)
-             (loop lst (- running 1))))))))
+             (progress total completed
+                       (lambda ()
+                         (loop lst running completed)))))))))
 
 (define* (build-guix out tarball
-                     #:key tar gzip gcrypt)
-  "Build and install Guix in directory OUT using source from TARBALL."
+                     #:key tar gzip gcrypt
+                     (debug-port (%make-void-port "w")))
+  "Build and install Guix in directory OUT using source from TARBALL.  Write
+any debugging output to DEBUG-PORT."
   (setvbuf (current-output-port) _IOLBF)
   (setvbuf (current-error-port) _IOLBF)
 
   (setenv "PATH" (string-append tar "/bin:" gzip "/bin"))
 
-  (system* "tar" "xvf" tarball)
+  (format debug-port "extracting '~a'...~%" tarball)
+  (system* "tar" "xf" tarball)
+
   (match (scandir "." (lambda (name)
                         (and (not (member name '("." "..")))
                              (file-is-directory? name))))
@@ -92,11 +120,13 @@ exit with non-zero."
     (x
      (error "tarball did not produce a single source directory" x)))
 
-  (format #t "copying and compiling Guix to `~a'...~%" out)
+  (format #t "copying and compiling to '~a'...~%" out)
 
   ;; Copy everything under guix/ and gnu/ plus {guix,gnu}.scm.
-  (copy-recursively "guix" (string-append out "/guix"))
-  (copy-recursively "gnu" (string-append out "/gnu"))
+  (copy-recursively "guix" (string-append out "/guix")
+                    #:log debug-port)
+  (copy-recursively "gnu" (string-append out "/gnu")
+                    #:log debug-port)
   (copy-file "guix.scm" (string-append out "/guix.scm"))
   (copy-file "gnu.scm" (string-append out "/gnu.scm"))
 
@@ -121,12 +151,12 @@ exit with non-zero."
   (p-for-each (lambda (file)
                 (let ((go (string-append (string-drop-right file 4)
                                          ".go")))
-                  (format (current-error-port)
-                          "compiling '~a'...~%" file)
-                  (compile-file file
-                                #:output-file go
-                                #:opts
-                                %auto-compilation-options)))
+                  (format debug-port "~%compiling '~a'...~%" file)
+                  (parameterize ((current-warning-port debug-port))
+                    (compile-file file
+                                  #:output-file go
+                                  #:opts
+                                  %auto-compilation-options))))
 
               (filter (cut string-suffix? ".scm" <>)
 
@@ -144,6 +174,7 @@ exit with non-zero."
   (delete-file (string-append out "/guix/config.scm"))
   (delete-file (string-append out "/guix/config.go"))
 
+  (newline)
   #t)
 
 ;;; pull.scm ends here
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index c2bf536e86..5dafb84f91 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -38,15 +38,21 @@
   "http://git.savannah.gnu.org/cgit/guix.git/snapshot/guix-master.tar.gz"
   )
 
-(define (unpack store tarball)
+(define* (unpack store tarball #:key verbose?)
   "Return a derivation that unpacks TARBALL into STORE and compiles Scheme
 files."
   (define builder
-    '(begin
+    `(begin
        (use-modules (guix build pull))
 
        (build-guix (assoc-ref %outputs "out")
                    (assoc-ref %build-inputs "tarball")
+
+                   ;; XXX: This is not perfect, enabling VERBOSE? means
+                   ;; building a different derivation.
+                   #:debug-port (if ',verbose?
+                                    (current-error-port)
+                                    (%make-void-port "w"))
                    #:tar (assoc-ref %build-inputs "tar")
                    #:gzip (assoc-ref %build-inputs "gzip")
                    #:gcrypt (assoc-ref %build-inputs "gcrypt"))))
@@ -129,13 +135,10 @@ Download and deploy the latest version of Guix.\n"))
                         (package-derivation store
                                             (if (assoc-ref opts 'bootstrap?)
                                                 %bootstrap-guile
-                                                (canonical-package guile-2.0))))
-                       (current-build-output-port
-                        (if (assoc-ref opts 'verbose?)
-                            (current-error-port)
-                            (%make-void-port "w"))))
+                                                (canonical-package guile-2.0)))))
           (let* ((config-dir (config-directory))
-                 (source     (unpack store tarball))
+                 (source     (unpack store tarball
+                                     #:verbose? (assoc-ref opts 'verbose?)))
                  (source-dir (derivation->output-path source)))
             (if (show-what-to-build store (list source))
                 (if (build-derivations store (list source))