Add (guix diagnostics).

* guix/ui.scm (warning, info, report-error, leave)
(location->string, guix-warning-port, program-name)
(highlight-argument, %highlight-argument, define-diagnostic)
(%warning-color, %info-color, %error-color)
(print-diagnostic-prefix): Move to...
* guix/diagnostics.scm: ... here.  New file.
* Makefile.am (MODULES): Add it.

Makefile.am

@@ -144,6 +144,7 @@ MODULES =					\
   guix/svn-download.scm				\
   guix/colors.scm				\
   guix/i18n.scm					\
+  guix/diagnostics.scm				\
   guix/ui.scm					\
   guix/status.scm				\
   guix/build/android-ndk-build-system.scm	\

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))

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
+  ;; Re-exports for backward compatibility.
-            display-hint
+  #:re-export (G_ N_ P_                           ;now in (guix i18n)
-            leave
+
+               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))