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.

1 files changed, 11 insertions, 141 deletions

diff --git a/guix/ui.scm b/guix/ui.scm
index 529401eea8..0b4fe144b6 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))