Merge branch 'master' into staging

7 files changed, 213 insertions, 113 deletions

diff --git a/guix/build/guile-build-system.scm b/guix/build/guile-build-system.scm
index 0bed049436..31f0d3d6f4 100644
--- a/guix/build/guile-build-system.scm
+++ b/guix/build/guile-build-system.scm
@@ -65,6 +65,62 @@ Return #false if it cannot be determined."
      (setenv "GUIX_LOCPATH" (string-append locales "/lib/locale"))
      #t)))
 
+(define* (invoke-each commands
+                      #:key (max-processes (current-processor-count))
+                      report-progress)
+  "Run each command in COMMANDS in a separate process, using up to
+MAX-PROCESSES processes in parallel.  Call REPORT-PROGRESS at each step.
+Raise an error if one of the processes exit with non-zero."
+  (define total
+    (length commands))
+
+  (define (wait-for-one-process)
+    (match (waitpid WAIT_ANY)
+      ((_ . status)
+       (unless (zero? (status:exit-val status))
+         (error "process failed" status)))))
+
+  (define (fork-and-run-command command)
+    (match (primitive-fork)
+      (0
+       (dynamic-wind
+         (const #t)
+         (lambda ()
+           (apply execlp command))
+         (lambda ()
+           (primitive-exit 127))))
+      (pid
+       #t)))
+
+  (let loop ((commands  commands)
+             (running   0)
+             (completed 0))
+    (match commands
+      (()
+       (or (zero? running)
+           (let ((running   (- running 1))
+                 (completed (+ completed 1)))
+             (wait-for-one-process)
+             (report-progress total completed)
+             (loop commands running completed))))
+      ((command . rest)
+       (if (< running max-processes)
+           (let ((running (+ 1 running)))
+             (fork-and-run-command command)
+             (loop rest running completed))
+           (let ((running   (- running 1))
+                 (completed (+ completed 1)))
+             (wait-for-one-process)
+             (report-progress total completed)
+             (loop commands running completed)))))))
+
+(define* (report-build-progress total completed
+                                #:optional (log-port (current-error-port)))
+  "Report that COMPLETED out of TOTAL files have been completed."
+  (format log-port "compiling...\t~5,1f% of ~d files~%" ;FIXME: i18n
+          (* 100. (/ completed total)) total)
+  (force-output log-port))
+
 (define* (build #:key outputs inputs native-inputs
                 (source-directory ".")
                 (compile-flags '())
@@ -101,24 +157,30 @@ Return #false if it cannot be determined."
                            (match (getenv "GUILE_LOAD_COMPILED_PATH")
                              (#f "")
                              (path (string-append ":" path)))))
-    (for-each (lambda (file)
-                (let* ((go (string-append go-dir
-                                          (file-sans-extension file)
-                                          ".go")))
-                  ;; Install source module.
-                  (install-file (string-append source-directory "/" file)
-                                (string-append module-dir
-                                               "/" (dirname file)))
-
-                  ;; Install and compile module.
-                  (apply invoke guild "compile" "-L" source-directory
-                         "-o" go
-                         (string-append source-directory "/" file)
-                         flags)))
-
-              ;; Arrange to strip SOURCE-DIRECTORY from file names.
-              (with-directory-excursion source-directory
-                (find-files "." scheme-file-regexp)))
+
+  (let ((source-files
+           (with-directory-excursion source-directory
+             (find-files "." scheme-file-regexp))))
+    (invoke-each
+     (map (lambda (file)
+            (cons* guild
+                   "guild" "compile"
+                   "-L" source-directory
+                   "-o" (string-append go-dir
+                                       (file-sans-extension file)
+                                       ".go")
+                   (string-append source-directory "/" file)
+                   flags))
+          source-files)
+     #:max-processes (parallel-job-count)
+     #:report-progress report-build-progress)
+
+    (for-each
+     (lambda (file)
+         (install-file (string-append source-directory "/" file)
+                       (string-append module-dir
+                                      "/" (dirname file))))
+     source-files))
     #t))
 
 (define* (install-documentation #:key outputs
diff --git a/guix/channels.scm b/guix/channels.scm
index 9658cf9393..e93879e1b4 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -52,6 +52,7 @@
             channel-location
 
             %default-channels
+            guix-channel?
 
             channel-instance?
             channel-instance-channel
diff --git a/guix/config.scm.in b/guix/config.scm.in
index d2ec9921c6..247b15ed81 100644
--- a/guix/config.scm.in
+++ b/guix/config.scm.in
@@ -33,7 +33,6 @@
             %config-directory
 
             %system
-            %libgcrypt
             %libz
             %gzip
             %bzip2
@@ -88,9 +87,6 @@
 (define %system
   "@guix_system@")
 
-(define %libgcrypt
-  "@LIBGCRYPT@")
-
 (define %libz
   "@LIBZ@")
 
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index fc0c0e2ad3..ba143ad16b 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -635,8 +635,7 @@ options handled by 'set-build-options-from-command-line', and listed in
 
 (define %default-options
   ;; Alist of default option values.
-  `((system . ,(%current-system))
-    (build-mode . ,(build-mode normal))
+  `((build-mode . ,(build-mode normal))
     (graft? . #t)
     (substitutes? . #t)
     (build-hook? . #t)
@@ -729,8 +728,7 @@ must be one of 'package', 'all', or 'transitive'~%")
                           rest)))
          (option '(#\s "system") #t #f
                  (lambda (opt name arg result)
-                   (alist-cons 'system arg
-                               (alist-delete 'system result eq?))))
+                   (alist-cons 'system arg result)))
          (option '("target") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'target arg
@@ -811,56 +809,71 @@ build."
        (cut package-cross-derivation <> <> triplet <>))))
 
   (define src    (assoc-ref opts 'source))
-  (define system (assoc-ref opts 'system))
   (define graft? (assoc-ref opts 'graft?))
+  (define systems
+    (match (filter-map (match-lambda
+                         (('system . system) system)
+                         (_ #f))
+                       opts)
+      (()      (list (%current-system)))
+      (systems systems)))
+
+  (define things-to-build
+    (map (cut transform store <>)
+         (options->things-to-build opts)))
+
+  (define (compute-derivation obj system)
+    ;; Compute the derivation of OBJ for SYSTEM.
+    (match obj
+      ((? package? p)
+       (let ((p (or (and graft? (package-replacement p)) p)))
+         (match src
+           (#f
+            (list (package->derivation store p system)))
+           (#t
+            (match (package-source p)
+              (#f
+               (format (current-error-port)
+                       (G_ "~a: warning: \
+package '~a' has no source~%")
+                       (location->string (package-location p))
+                       (package-name p))
+               '())
+              (s
+               (list (package-source-derivation store s)))))
+           (proc
+            (map (cut package-source-derivation store <>)
+                 (proc p))))))
+      ((? derivation? drv)
+       (list drv))
+      ((? procedure? proc)
+       (list (run-with-store store
+               (mbegin %store-monad
+                 (set-guile-for-build (default-guile))
+                 (proc))
+               #:system system)))
+      ((? file-like? obj)
+       (list (run-with-store store
+               (lower-object obj system
+                             #:target (assoc-ref opts 'target))
+               #:system system)))
+      ((? gexp? gexp)
+       (list (run-with-store store
+               (mbegin %store-monad
+                 (set-guile-for-build (default-guile))
+                 (gexp->derivation "gexp" gexp
+                                   #:system system))
+               #:system system)))))
 
   ;; We may get 'unbound-variable' errors while evaluating the 'inputs' fields
   ;; of user packages.  Since 'guix build' is the primary tool for people
   ;; testing new packages, report such errors gracefully.
   (with-unbound-variable-handling
    (parameterize ((%graft? graft?))
-     (append-map (match-lambda
-                   ((? package? p)
-                    (let ((p (or (and graft? (package-replacement p)) p)))
-                      (match src
-                        (#f
-                         (list (package->derivation store p system)))
-                        (#t
-                         (match (package-source p)
-                           (#f
-                            (format (current-error-port)
-                                    (G_ "~a: warning: \
-package '~a' has no source~%")
-                                    (location->string (package-location p))
-                                    (package-name p))
-                            '())
-                           (s
-                            (list (package-source-derivation store s)))))
-                        (proc
-                         (map (cut package-source-derivation store <>)
-                              (proc p))))))
-                   ((? derivation? drv)
-                    (list drv))
-                   ((? procedure? proc)
-                    (list (run-with-store store
-                            (mbegin %store-monad
-                              (set-guile-for-build (default-guile))
-                              (proc))
-                            #:system system)))
-                   ((? file-like? obj)
-                    (list (run-with-store store
-                            (lower-object obj system
-                                          #:target (assoc-ref opts 'target))
-                            #:system system)))
-                   ((? gexp? gexp)
-                    (list (run-with-store store
-                            (mbegin %store-monad
-                              (set-guile-for-build (default-guile))
-                              (gexp->derivation "gexp" gexp
-                                                #:system system))
-                            #:system system))))
-                 (map (cut transform store <>)
-                      (options->things-to-build opts))))))
+     (append-map (lambda (system)
+                   (append-map (cut compute-derivation <> system)
+                               things-to-build))
+                 systems))))
 
 (define (show-build-log store file urls)
   "Show the build log for FILE, falling back to remote logs from URLS if
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index ddad5b7fd0..dc338a1d7b 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -45,7 +45,6 @@
   #:use-module (guix cve)
   #:use-module (gnu packages)
   #:use-module (ice-9 match)
-  #:use-module (ice-9 receive)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 format)
   #:use-module (web client)
@@ -796,10 +795,13 @@ descriptions maintained upstream."
       (let ((uris (origin-uris origin)))
         (for-each check-mirror-uri uris)))))
 
-(define (check-github-url package)
+(define* (check-github-url package #:key (timeout 3))
   "Check whether PACKAGE uses source URLs that redirect to GitHub."
-  (define (follow-redirect uri)
-    (receive (response body) (http-head uri)
+  (define (follow-redirect url)
+    (let* ((uri      (string->uri url))
+           (port     (guix:open-connection-for-uri uri #:timeout timeout))
+           (response (http-head uri #:port port)))
+      (close-port port)
       (case (response-code response)
         ((301 302)
          (uri->string (assoc-ref (response-headers response) 'location)))
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 55137fce8f..3929cd402e 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -86,6 +86,8 @@ Download and deploy the latest version of Guix.\n"))
   (display (G_ "
       --branch=BRANCH    download the tip of the specified BRANCH"))
   (display (G_ "
+  -N, --news             display news compared to the previous generation"))
+  (display (G_ "
   -l, --list-generations[=PATTERN]
                          list generations matching PATTERN"))
   (display (G_ "
@@ -117,6 +119,9 @@ Download and deploy the latest version of Guix.\n"))
                  (lambda (opt name arg result)
                    (cons `(query list-generations ,(or arg ""))
                          result)))
+         (option '(#\N "news") #f #f
+                 (lambda (opt name arg result)
+                   (cons '(query display-news) result)))
          (option '("url") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'repository-url arg
@@ -162,25 +167,33 @@ Download and deploy the latest version of Guix.\n"))
 (define indirect-root-added
   (store-lift add-indirect-root))
 
-(define (display-profile-news profile)
-  "Display what's up in PROFILE--new packages, and all that."
+(define* (display-profile-news profile #:key concise?
+                               current-is-newer?)
+  "Display what's up in PROFILE--new packages, and all that.  If
+CURRENT-IS-NEWER? is true, assume that the current process represents the
+newest generation of PROFILE.x"
   (match (memv (generation-number profile)
                (reverse (profile-generations profile)))
     ((current previous _ ...)
-     (newline)
-     (let ((old (fold-available-packages
-                 (lambda* (name version result
-                                #:key supported? deprecated?
-                                #:allow-other-keys)
-                   (if (and supported? (not deprecated?))
-                       (alist-cons name version result)
-                       result))
-                 '()))
-           (new (profile-package-alist
-                 (generation-file-name profile current))))
-       (display-new/upgraded-packages old new
-                                      #:concise? #t
-                                      #:heading (G_ "New in this revision:\n"))))
+     (let ((these (fold-available-packages
+                   (lambda* (name version result
+                                  #:key supported? deprecated?
+                                  #:allow-other-keys)
+                     (if (and supported? (not deprecated?))
+                         (alist-cons name version result)
+                         result))
+                   '()))
+           (those (profile-package-alist
+                   (generation-file-name profile
+                                         (if current-is-newer?
+                                             previous
+                                             current)))))
+       (let ((old (if current-is-newer? those these))
+             (new (if current-is-newer? these those)))
+         (display-new/upgraded-packages old new
+                                        #:concise? concise?
+                                        #:heading
+                                        (G_ "New in this revision:\n")))))
     (_ #t)))
 
 (define* (build-and-install instances profile
@@ -196,7 +209,8 @@ true, display what would be built without actually building it."
                       #:hooks %channel-profile-hooks
                       #:dry-run? dry-run?)
       (munless dry-run?
-        (return (display-profile-news profile))
+        (return (newline))
+        (return (display-profile-news profile #:concise? #t))
         (match (which "guix")
           (#f (return #f))
           (str
@@ -394,9 +408,13 @@ display long package lists that would fill the user's screen."
                                      column)
                      4))
 
+  (define concise/max-item-count
+    ;; Maximum number of items to display when CONCISE? is true.
+    12)
+
   (define list->enumeration
     (if concise?
-        (lambda* (lst #:optional (max 12))
+        (lambda* (lst #:optional (max concise/max-item-count))
           (if (> (length lst) max)
               (string-append (string-join (take lst max) ", ")
                              ", " (ellipsis))
@@ -404,10 +422,13 @@ display long package lists that would fill the user's screen."
         (cut string-join <> ", ")))
 
   (let-values (((new upgraded) (new/upgraded-packages alist1 alist2)))
+    (define new-count (length new))
+    (define upgraded-count (length upgraded))
+
     (unless (and (null? new) (null? upgraded))
       (display heading))
 
-    (match (length new)
+    (match new-count
       (0 #t)
       (count
        (format #t (N_ "  ~h new package: ~a~%"
@@ -415,14 +436,20 @@ display long package lists that would fill the user's screen."
                count
                (pretty (list->enumeration (sort (map first new) string<?))
                        30))))
-    (match (length upgraded)
+    (match upgraded-count
       (0 #t)
       (count
        (format #t (N_ "  ~h package upgraded: ~a~%"
                       "  ~h packages upgraded: ~a~%" count)
                count
                (pretty (list->enumeration (sort upgraded string<?))
-                       35))))))
+                       35))))
+
+    (when (and concise?
+               (or (> new-count concise/max-item-count)
+                   (> upgraded-count concise/max-item-count)))
+      (display-hint (G_ "Run @command{guix pull --news} to view the complete
+list of package changes.")))))
 
 (define (display-profile-content-diff profile gen1 gen2)
   "Display the changes in PROFILE GEN2 compared to generation GEN1."
@@ -462,7 +489,12 @@ display long package lists that would fill the user's screen."
                (()
                 (exit 1))
                ((numbers ...)
-                (list-generations profile numbers)))))))))
+                (list-generations profile numbers)))))))
+    (('display-news)
+     ;; Display profile news, with the understanding that this process
+     ;; represents the newest generation.
+     (display-profile-news profile
+                           #:current-is-newer? #t))))
 
 (define (channel-list opts)
   "Return the list of channels to use.  If OPTS specify a channel file,
@@ -502,24 +534,22 @@ Use '~/.config/guix/channels.scm' instead."))
         (url (or (assoc-ref opts 'repository-url)
                  (environment-variable))))
     (if (or ref url)
-        (match channels
-          ((one)
-           ;; When there's only one channel, apply '--url', '--commit', and
-           ;; '--branch' to this specific channel.
-           (let ((url (or url (channel-url one))))
-             (list (match ref
+        (match (find guix-channel? channels)
+          ((? channel? guix)
+           ;; Apply '--url', '--commit', and '--branch' to the 'guix' channel.
+           (let ((url (or url (channel-url guix))))
+             (cons (match ref
                      (('commit . commit)
-                      (channel (inherit one)
+                      (channel (inherit guix)
                                (url url) (commit commit) (branch #f)))
                      (('branch . branch)
-                      (channel (inherit one)
+                      (channel (inherit guix)
                                (url url) (commit #f) (branch branch)))
                      (#f
-                      (channel (inherit one) (url url)))))))
-          (_
-           ;; Otherwise bail out.
-           (leave
-            (G_ "'--url', '--commit', and '--branch' are not applicable~%"))))
+                      (channel (inherit guix) (url url))))
+                   (remove guix-channel? channels))))
+          (#f                           ;no 'guix' channel, failure will ensue
+           channels))
         channels)))
 
 
@@ -531,11 +561,11 @@ Use '~/.config/guix/channels.scm' instead."))
             (cache    (string-append (cache-directory) "/pull"))
             (channels (channel-list opts))
             (profile  (or (assoc-ref opts 'profile) %current-profile)))
-       (ensure-default-profile)
        (cond ((assoc-ref opts 'query)
               (process-query opts profile))
              (else
               (with-store store
+                (ensure-default-profile)
                 (with-status-verbosity (assoc-ref opts 'verbosity)
                   (parameterize ((%current-system (assoc-ref opts 'system))
                                  (%graft? (assoc-ref opts 'graft?))
diff --git a/guix/self.scm b/guix/self.scm
index 7ba2764eb9..de921e6d9c 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -753,10 +753,6 @@ Info manual."
 ;;; Generating (guix config).
 ;;;
 
-(define %dependency-variables
-  ;; (guix config) variables corresponding to dependencies.
-  '(%libz %xz %gzip %bzip2))
-
 (define %persona-variables
   ;; (guix config) variables that define Guix's persona.
   '(%guix-package-name