Merge branch 'master' into staging

5 files changed, 229 insertions, 220 deletions

diff --git a/guix/channels.scm b/guix/channels.scm
index e93879e1b..e7278c606 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -27,7 +27,7 @@
   #:use-module (guix profiles)
   #:use-module (guix derivations)
   #:use-module (guix combinators)
-  #:use-module (guix deprecation)
+  #:use-module (guix diagnostics)
   #:use-module (guix store)
   #:use-module (guix i18n)
   #:use-module ((guix utils)
@@ -280,7 +280,7 @@ package modules under SOURCE using CORE, an instance of Guix."
                       ;; Disable deprecation warnings; it's OK for SCRIPT to
                       ;; use deprecated APIs and the user doesn't have to know
                       ;; about it.
-                      (parameterize ((deprecation-warning-port
+                      (parameterize ((guix-warning-port
                                       (%make-void-port "w")))
                         (primitive-load script))))))
         ;; BUILD must be a monadic procedure of at least one argument: the
diff --git a/guix/deprecation.scm b/guix/deprecation.scm
index 2f7c05894..468b2e9b7 100644
--- a/guix/deprecation.scm
+++ b/guix/deprecation.scm
@@ -18,39 +18,26 @@
 
 (define-module (guix deprecation)
   #:use-module (guix i18n)
-  #:use-module (ice-9 format)
+  #:use-module (guix diagnostics)
+  #:autoload   (guix utils) (source-properties->location)
   #:export (define-deprecated
             define-deprecated/alias
-            deprecation-warning-port))
+            warn-about-deprecation))
 
 ;;; Commentary:
 ;;;
 ;;; Provide a mechanism to mark bindings as deprecated.
 ;;;
-;;; We don't reuse (guix ui) mostly to avoid pulling in too many things.
-;;;
 ;;; Code:
 
-(define deprecation-warning-port
-  ;; Port where deprecation warnings go.
-  (make-parameter (current-error-port)))
-
-(define (source-properties->location-string properties)
-  "Return a human-friendly, GNU-standard representation of PROPERTIES, a
-source property alist."
-  (let ((file   (assq-ref properties 'filename))
-        (line   (assq-ref properties 'line))
-        (column (assq-ref properties 'column)))
-    (if (and file line column)
-        (format #f "~a:~a:~a" file (+ 1 line) column)
-        (G_ "<unknown location>"))))
-
 (define* (warn-about-deprecation variable properties
                                  #:key replacement)
-  (format (deprecation-warning-port)
-          (G_ "~a: warning: '~a' is deprecated~@[, use '~a' instead~]~%")
-          (source-properties->location-string properties)
-          variable replacement))
+  (let ((location (and properties (source-properties->location properties))))
+    (if replacement
+        (warning location (G_ "'~a' is deprecated, use '~a' instead~%")
+                 variable replacement)
+        (warning location (G_ "'~a' is deprecated~%")
+                 variable))))
 
 (define-syntax define-deprecated
   (lambda (s)
@@ -59,7 +46,7 @@ source property alist."
   (define-deprecated foo bar 42)
   (define-deprecated (baz x y) qux (qux y x))
 
-This will write a deprecation warning to DEPRECATION-WARNING-PORT."
+This will write a deprecation warning to GUIX-WARNING-PORT."
     (syntax-case s ()
       ((_ (proc formals ...) replacement body ...)
        #'(define-deprecated proc replacement
@@ -96,7 +83,7 @@ these lines:
 
 where 'nix-server?' is the deprecated name for 'store-connection?'.
 
-This will write a deprecation warning to DEPRECATION-WARNING-PORT."
+This will write a deprecation warning to GUIX-WARNING-PORT."
   (define-syntax deprecated
     (lambda (s)
       (warn-about-deprecation 'deprecated (syntax-source s)
diff --git a/guix/diagnostics.scm b/guix/diagnostics.scm
new file mode 100644
index 000000000..380cfbb61
--- /dev/null
+++ b/guix/diagnostics.scm
@@ -0,0 +1,173 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix diagnostics)
+  #:use-module (guix colors)
+  #:use-module (guix i18n)
+  #:autoload   (guix utils) (<location>)
+  #:use-module (srfi srfi-26)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
+  #:export (warning
+            info
+            report-error
+            leave
+
+            location->string
+
+            guix-warning-port
+            program-name))
+
+;;; Commentary:
+;;;
+;;; This module provides the tools to report diagnostics to the user in a
+;;; consistent way: errors, warnings, and notes.
+;;;
+;;; Code:
+
+(define-syntax highlight-argument
+  (lambda (s)
+    "Given FMT and ARG, expand ARG to a call that highlights it, provided FMT
+is a trivial format string."
+    (define (trivial-format-string? fmt)
+      (define len
+        (string-length fmt))
+
+      (let loop ((start 0))
+        (or (>= (+ 1 start) len)
+            (let ((tilde (string-index fmt #\~ start)))
+              (or (not tilde)
+                  (case (string-ref fmt (+ tilde 1))
+                    ((#\a #\A #\%) (loop (+ tilde 2)))
+                    (else          #f)))))))
+
+    ;; Be conservative: limit format argument highlighting to cases where the
+    ;; format string contains nothing but ~a escapes.  If it contained ~s
+    ;; escapes, this strategy wouldn't work.
+    (syntax-case s ()
+      ((_ "~a~%" arg)                          ;don't highlight whole messages
+       #'arg)
+      ((_ fmt arg)
+       (trivial-format-string? (syntax->datum #'fmt))
+       #'(%highlight-argument arg))
+      ((_ fmt arg)
+       #'arg))))
+
+(define* (%highlight-argument arg #:optional (port (guix-warning-port)))
+  "Highlight ARG, a format string argument, if PORT supports colors."
+  (cond ((string? arg)
+         (highlight arg port))
+        ((symbol? arg)
+         (highlight (symbol->string arg) port))
+        (else arg)))
+
+(define-syntax define-diagnostic
+  (syntax-rules ()
+    "Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all
+messages."
+    ((_ name (G_ prefix) colors)
+     (define-syntax name
+       (lambda (x)
+         (syntax-case x ()
+           ((name location (underscore fmt) args (... ...))
+            (and (string? (syntax->datum #'fmt))
+                 (free-identifier=? #'underscore #'G_))
+            #'(begin
+                (print-diagnostic-prefix prefix location
+                                         #:colors colors)
+                (format (guix-warning-port) (gettext fmt %gettext-domain)
+                        (highlight-argument fmt args) (... ...))))
+           ((name location (N-underscore singular plural n)
+                  args (... ...))
+            (and (string? (syntax->datum #'singular))
+                 (string? (syntax->datum #'plural))
+                 (free-identifier=? #'N-underscore #'N_))
+            #'(begin
+                (print-diagnostic-prefix prefix location
+                                         #:colors colors)
+                (format (guix-warning-port)
+                        (ngettext singular plural n %gettext-domain)
+                        (highlight-argument singular args) (... ...))))
+           ((name (underscore fmt) args (... ...))
+            (free-identifier=? #'underscore #'G_)
+            #'(name #f (underscore fmt) args (... ...)))
+           ((name (N-underscore singular plural n)
+                  args (... ...))
+            (free-identifier=? #'N-underscore #'N_)
+            #'(name #f (N-underscore singular plural n)
+                    args (... ...)))))))))
+
+;; XXX: This doesn't work well for right-to-left languages.
+;; TRANSLATORS: The goal is to emit "warning:" followed by a short phrase;
+;; "~a" is a placeholder for that phrase.
+(define-diagnostic warning (G_ "warning: ") %warning-color) ;emit a warning
+(define-diagnostic info (G_ "") %info-color)
+(define-diagnostic report-error (G_ "error: ") %error-color)
+
+(define-syntax-rule (leave args ...)
+  "Emit an error message and exit."
+  (begin
+    (report-error args ...)
+    (exit 1)))
+
+(define %warning-color (color BOLD MAGENTA))
+(define %info-color (color BOLD))
+(define %error-color (color BOLD RED))
+
+(define* (print-diagnostic-prefix prefix #:optional location
+                                  #:key (colors (color)))
+  "Print PREFIX as a diagnostic line prefix."
+  (define color?
+    (color-output? (guix-warning-port)))
+
+  (define location-color
+    (if color?
+        (cut colorize-string <> (color BOLD))
+        identity))
+
+  (define prefix-color
+    (if color?
+        (lambda (prefix)
+          (colorize-string prefix colors))
+        identity))
+
+  (let ((prefix (if (string-null? prefix)
+                    prefix
+                    (gettext prefix %gettext-domain))))
+    (if location
+        (format (guix-warning-port) "~a: ~a"
+                (location-color (location->string location))
+                (prefix-color prefix))
+        (format (guix-warning-port) "~:[~*~;guix ~a: ~]~a"
+                (program-name) (program-name)
+                (prefix-color prefix)))))
+
+(define (location->string loc)
+  "Return a human-friendly, GNU-standard representation of LOC."
+  (match loc
+    (#f (G_ "<unknown location>"))
+    (($ <location> file line column)
+     (format #f "~a:~a:~a" file line column))))
+
+
+(define guix-warning-port
+  (make-parameter (current-warning-port)))
+
+(define program-name
+  ;; Name of the command-line program currently executing, or #f.
+  (make-parameter #f))
diff --git a/guix/import/utils.scm b/guix/import/utils.scm
index 516c0cfaa..d0dffe9b0 100644
--- a/guix/import/utils.scm
+++ b/guix/import/utils.scm
@@ -4,6 +4,7 @@
 ;;; Copyright © 2016 David Craven <david@craven.ch>
 ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
+;;; Copyright © 2019 Robert Vollmert <rob@vllmrt.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -378,57 +379,35 @@ separated by PRED."
                            #:allow-other-keys)
   "Generate a stream of package expressions for PACKAGE-NAME and all its
 dependencies."
-  (receive (package . dependencies)
-      (repo->guix-package package-name repo)
-    (if (not package)
-        stream-null
+  (define (exists? dependency)
+    (not (null? (find-packages-by-name (guix-name dependency)))))
+  (define initial-state (list #f (list package-name) (list)))
+  (define (step state)
+    (match state
+      ((prev (next . rest) done)
+       (define (handle? dep)
+         (and
+           (not (equal? dep next))
+           (not (member dep done))
+           (not (exists? dep))))
+       (receive (package . dependencies) (repo->guix-package next repo)
+         (list
+           (if package package '()) ;; default #f on failure would interrupt
+           (if package
+             (lset-union equal? rest (filter handle? (car dependencies)))
+             rest)
+           (cons next done))))
+      ((prev '() done)
+       (list #f '() done))))
 
-        ;; Generate a lazy stream of package expressions for all unknown
-        ;; dependencies in the graph.
-        (let* ((make-state (lambda (queue done)
-                             (cons queue done)))
-               (next       (match-lambda
-                             (((next . rest) . done) next)))
-               (imported   (match-lambda
-                             ((queue . done) done)))
-               (done?      (match-lambda
-                             ((queue . done)
-                              (zero? (length queue)))))
-               (unknown?   (lambda* (dependency #:optional (done '()))
-                             (and (not (member dependency
-                                               done))
-                                  (null? (find-packages-by-name
-                                          (guix-name dependency))))))
-               (update     (lambda (state new-queue)
-                             (match state
-                               (((head . tail) . done)
-                                (make-state (lset-difference
-                                             equal?
-                                             (lset-union equal? new-queue tail)
-                                             done)
-                                            (cons head done)))))))
-          (stream-cons
-           package
-           (stream-unfold
-            ;; map: produce a stream element
-            (lambda (state)
-              (repo->guix-package (next state) repo))
-
-            ;; predicate
-            (negate done?)
-
-            ;; generator: update the queue
-            (lambda (state)
-              (receive (package . dependencies)
-                  (repo->guix-package (next state) repo)
-                (if package
-                    (update state (filter (cut unknown? <>
-                                               (cons (next state)
-                                                     (imported state)))
-                                          (car dependencies)))
-                    ;; TODO: Try the other archives before giving up
-                    (update state (imported state)))))
-
-            ;; initial state
-            (make-state (filter unknown? (car dependencies))
-                        (list package-name))))))))
+  ;; Generate a lazy stream of package expressions for all unknown
+  ;; dependencies in the graph.
+  (stream-unfold
+    ;; map: produce a stream element
+    (match-lambda ((latest queue done) latest))
+    ;; predicate
+    (match-lambda ((latest queue done) latest))
+    ;; generator: update the queue
+    step
+    ;; initial state
+    (step initial-state)))
diff --git a/guix/ui.scm b/guix/ui.scm
index 529401eea..0b4fe144b 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -32,6 +32,7 @@
 (define-module (guix ui)
   #:use-module (guix i18n)
   #:use-module (guix colors)
+  #:use-module (guix diagnostics)
   #:use-module (guix gexp)
   #:use-module (guix sets)
   #:use-module (guix utils)
@@ -70,10 +71,14 @@
   #:use-module (texinfo)
   #:use-module (texinfo plain-text)
   #:use-module (texinfo string-utils)
-  #:re-export (G_ N_ P_)                          ;backward compatibility
-  #:export (report-error
-            display-hint
-            leave
+
+  ;; Re-exports for backward compatibility.
+  #:re-export (G_ N_ P_                           ;now in (guix i18n)
+
+               warning info report-error leave    ;now in (guix diagnostics)
+               location->string
+               guix-warning-port program-name)
+  #:export (display-hint
             make-user-module
             load*
             warn-about-load-error
@@ -93,7 +98,6 @@
             read/eval
             read/eval-package-expression
             check-available-space
-            location->string
             fill-paragraph
             %text-width
             texi->plain-text
@@ -115,10 +119,6 @@
             delete-generation*
             run-guix-command
             run-guix
-            program-name
-            guix-warning-port
-            warning
-            info
             guix-main))
 
 ;;; Commentary:
@@ -127,124 +127,6 @@
 ;;;
 ;;; Code:
 
-(define-syntax highlight-argument
-  (lambda (s)
-    "Given FMT and ARG, expand ARG to a call that highlights it, provided FMT
-is a trivial format string."
-    (define (trivial-format-string? fmt)
-      (define len
-        (string-length fmt))
-
-      (let loop ((start 0))
-        (or (>= (+ 1 start) len)
-            (let ((tilde (string-index fmt #\~ start)))
-              (or (not tilde)
-                  (case (string-ref fmt (+ tilde 1))
-                    ((#\a #\A #\%) (loop (+ tilde 2)))
-                    (else          #f)))))))
-
-    ;; Be conservative: limit format argument highlighting to cases where the
-    ;; format string contains nothing but ~a escapes.  If it contained ~s
-    ;; escapes, this strategy wouldn't work.
-    (syntax-case s ()
-      ((_ "~a~%" arg)                          ;don't highlight whole messages
-       #'arg)
-      ((_ fmt arg)
-       (trivial-format-string? (syntax->datum #'fmt))
-       #'(%highlight-argument arg))
-      ((_ fmt arg)
-       #'arg))))
-
-(define* (%highlight-argument arg #:optional (port (guix-warning-port)))
-  "Highlight ARG, a format string argument, if PORT supports colors."
-  (cond ((string? arg)
-         (highlight arg port))
-        ((symbol? arg)
-         (highlight (symbol->string arg) port))
-        (else arg)))
-
-(define-syntax define-diagnostic
-  (syntax-rules ()
-    "Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all
-messages."
-    ((_ name (G_ prefix) colors)
-     (define-syntax name
-       (lambda (x)
-         (syntax-case x ()
-           ((name location (underscore fmt) args (... ...))
-            (and (string? (syntax->datum #'fmt))
-                 (free-identifier=? #'underscore #'G_))
-            #'(begin
-                (print-diagnostic-prefix prefix location
-                                         #:colors colors)
-                (format (guix-warning-port) (gettext fmt %gettext-domain)
-                        (highlight-argument fmt args) (... ...))))
-           ((name location (N-underscore singular plural n)
-                  args (... ...))
-            (and (string? (syntax->datum #'singular))
-                 (string? (syntax->datum #'plural))
-                 (free-identifier=? #'N-underscore #'N_))
-            #'(begin
-                (print-diagnostic-prefix prefix location
-                                         #:colors colors)
-                (format (guix-warning-port)
-                        (ngettext singular plural n %gettext-domain)
-                        (highlight-argument singular args) (... ...))))
-           ((name (underscore fmt) args (... ...))
-            (free-identifier=? #'underscore #'G_)
-            #'(name #f (underscore fmt) args (... ...)))
-           ((name (N-underscore singular plural n)
-                  args (... ...))
-            (free-identifier=? #'N-underscore #'N_)
-            #'(name #f (N-underscore singular plural n)
-                    args (... ...)))))))))
-
-;; XXX: This doesn't work well for right-to-left languages.
-;; TRANSLATORS: The goal is to emit "warning:" followed by a short phrase;
-;; "~a" is a placeholder for that phrase.
-(define-diagnostic warning (G_ "warning: ") %warning-color) ;emit a warning
-(define-diagnostic info (G_ "") %info-color)
-(define-diagnostic report-error (G_ "error: ") %error-color)
-
-(define-syntax-rule (leave args ...)
-  "Emit an error message and exit."
-  (begin
-    (report-error args ...)
-    (exit 1)))
-
-(define %warning-color (color BOLD MAGENTA))
-(define %info-color (color BOLD))
-(define %error-color (color BOLD RED))
-(define %hint-color (color BOLD CYAN))
-
-(define* (print-diagnostic-prefix prefix #:optional location
-                                  #:key (colors (color)))
-  "Print PREFIX as a diagnostic line prefix."
-  (define color?
-    (color-output? (guix-warning-port)))
-
-  (define location-color
-    (if color?
-        (cut colorize-string <> (color BOLD))
-        identity))
-
-  (define prefix-color
-    (if color?
-        (lambda (prefix)
-          (colorize-string prefix colors))
-        identity))
-
-  (let ((prefix (if (string-null? prefix)
-                    prefix
-                    (gettext prefix %gettext-domain))))
-    (if location
-        (format (guix-warning-port) "~a: ~a"
-                (location-color (location->string location))
-                (prefix-color prefix))
-        (format (guix-warning-port) "~:[~*~;guix ~a: ~]~a"
-                (program-name) (program-name)
-                (prefix-color prefix)))))
-
 (define (print-unbound-variable-error port key args default-printer)
   ;; Print unbound variable errors more nicely, and in the right language.
   (match args
@@ -393,6 +275,8 @@ VARIABLE and return it, or #f if none was found."
                   (('gnu _ ...) head)             ;must be that one
                   (_ (loop next (cons head suggestions) visited)))))))))))
 
+(define %hint-color (color BOLD CYAN))
+
 (define* (display-hint message #:optional (port (current-error-port)))
   "Display MESSAGE, a l10n message possibly containing Texinfo markup, to
 PORT."
@@ -1192,13 +1076,6 @@ replacement if PORT is not Unicode-capable."
       (lambda ()
         body ...)))))
 
-(define (location->string loc)
-  "Return a human-friendly, GNU-standard representation of LOC."
-  (match loc
-    (#f (G_ "<unknown location>"))
-    (($ <location> file line column)
-     (format #f "~a:~a:~a" file line column))))
-
 (define* (fill-paragraph str width #:optional (column 0))
   "Fill STR such that each line contains at most WIDTH characters, assuming
 that the first character is at COLUMN.
@@ -1720,10 +1597,6 @@ Run COMMAND with ARGS.\n"))
                                  string<?))
   (show-bug-report-information))
 
-(define program-name
-  ;; Name of the command-line program currently executing, or #f.
-  (make-parameter #f))
-
 (define (run-guix-command command . args)
   "Run COMMAND with the given ARGS.  Report an error when COMMAND is not
 found."
@@ -1783,9 +1656,6 @@ and signal handling has already been set up."
             (string->symbol command)
             args))))
 
-(define guix-warning-port
-  (make-parameter (current-warning-port)))
-
 (define (guix-main arg0 . args)
   (initialize-guix)
   (apply run-guix args))