diff options
| -rw-r--r-- | guix/diagnostics.scm | 65 | ||||
| -rw-r--r-- | guix/ui.scm | 62 |
2 files changed, 110 insertions, 17 deletions
diff --git a/guix/diagnostics.scm b/guix/diagnostics.scm index 3b536d8e96..7b9ffc61b5 100644 --- a/guix/diagnostics.scm +++ b/guix/diagnostics.scm @@ -19,6 +19,7 @@ (define-module (guix diagnostics) #:use-module (guix colors) #:use-module (guix i18n) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) #:use-module (srfi srfi-35) @@ -43,6 +44,11 @@ error-location? error-location + formatted-message + formatted-message? + formatted-message-string + formatted-message-arguments + &fix-hint fix-hint? condition-fix-hint @@ -255,6 +261,65 @@ a location object." fix-hint? (hint condition-fix-hint)) ;string +(define-condition-type &formatted-message &error + formatted-message? + (format formatted-message-string) + (arguments formatted-message-arguments)) + +(define (check-format-string location format args) + "Check that FORMAT, a format string, contains valid escapes, and that the +number of arguments in ARGS matches the escapes in FORMAT." + (define actual-count + (length args)) + + (define allowed-chars ;for 'simple-format' + '(#\A #\S #\a #\s #\~ #\%)) + + (define (format-chars fmt) + (let loop ((chars (string->list fmt)) + (result '())) + (match chars + (() + (reverse result)) + ((#\~ opt rest ...) + (loop rest (cons opt result))) + ((chr rest ...) + (and (memv chr allowed-chars) + (loop rest result)))))) + + (match (format-chars format) + (#f + ;; XXX: In this case it could be that FMT contains invalid escapes, or it + ;; could be that it contains escapes beyond ALLOWED-CHARS, for (ice-9 + ;; format). Instead of implementing '-Wformat', do nothing. + #f) + (chars + (let ((count (fold (lambda (chr count) + (case chr + ((#\~ #\%) count) + (else (+ count 1)))) + 0 + chars))) + (unless (= count actual-count) + (warning location (G_ "format string got ~a arguments, expected ~a~%") + actual-count count)))))) + +(define-syntax formatted-message + (lambda (s) + "Return a '&formatted-message' error condition." + (syntax-case s (G_) + ((_ (G_ str) args ...) + (string? (syntax->datum #'str)) + (let ((str (syntax->datum #'str))) + ;; Implement a subset of '-Wformat'. + (check-format-string (source-properties->location + (syntax-source s)) + str #'(args ...)) + (with-syntax ((str (string-append str "\n"))) + #'(condition + (&formatted-message (format str) + (arguments (list args ...)))))))))) + (define guix-warning-port (make-parameter (current-warning-port))) diff --git a/guix/ui.scm b/guix/ui.scm index 588eb8480e..162eb35d26 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -388,12 +388,18 @@ ARGS is the list of arguments received by the 'throw' handler." (('unbound-variable _ ...) (report-unbound-variable-error args #:frame frame)) (((or 'srfi-34 '%exception) obj) - (if (message-condition? obj) - (report-error (and (error-location? obj) - (error-location obj)) - (G_ "~a~%") - (gettext (condition-message obj) %gettext-domain)) - (report-error (G_ "exception thrown: ~s~%") obj)) + (cond ((message-condition? obj) + (report-error (and (error-location? obj) + (error-location obj)) + (G_ "~a~%") + (gettext (condition-message obj) %gettext-domain))) + ((formatted-message? obj) + (apply report-error + (and (error-location? obj) (error-location obj)) + (gettext (formatted-message-string obj) %gettext-domain) + (formatted-message-arguments obj))) + (else + (report-error (G_ "exception thrown: ~s~%") obj))) (when (fix-hint? obj) (display-hint (condition-fix-hint obj)))) ((key args ...) @@ -420,12 +426,19 @@ exiting. ARGS is the list of arguments received by the 'throw' handler." (('unbound-variable _ ...) (report-unbound-variable-error args)) (((or 'srfi-34 '%exception) obj) - (if (message-condition? obj) - (warning (G_ "failed to load '~a': ~a~%") - file - (gettext (condition-message obj) %gettext-domain)) - (warning (G_ "failed to load '~a': exception thrown: ~s~%") - file obj))) + (cond ((message-condition? obj) + (warning (G_ "failed to load '~a': ~a~%") + file + (gettext (condition-message obj) %gettext-domain))) + ((formatted-message? obj) + (warning (G_ "failed to load '~a': ~a~%") + (apply format #f + (gettext (formatted-message-string obj) + %gettext-domain) + (formatted-message-arguments obj)))) + (else + (warning (G_ "failed to load '~a': exception thrown: ~s~%") + file obj)))) ((error args ...) (warning (G_ "failed to load '~a':~%") module) (apply display-error #f (current-error-port) args) @@ -791,6 +804,15 @@ directories:~{ ~a~}~%") (display-hint (condition-fix-hint c))) (exit 1)) + ((formatted-message? c) + (apply report-error + (and (error-location? c) (error-location c)) + (gettext (formatted-message-string c) %gettext-domain) + (formatted-message-arguments c)) + (when (fix-hint? c) + (display-hint (condition-fix-hint c))) + (exit 1)) + ;; On Guile 3.0.0, exceptions such as 'unbound-variable' are ;; compound and include a '&message'. However, that message only ;; contains the format string. Thus, special-case it here to @@ -854,11 +876,17 @@ similar." (('syntax-error proc message properties form . rest) (report-error (G_ "syntax error: ~a~%") message)) (((or 'srfi-34 '%exception) obj) - (if (message-condition? obj) - (report-error (G_ "~a~%") - (gettext (condition-message obj) - %gettext-domain)) - (report-error (G_ "exception thrown: ~s~%") obj))) + (cond ((message-condition? obj) + (report-error (G_ "~a~%") + (gettext (condition-message obj) + %gettext-domain))) + ((formatted-message? obj) + (apply report-error #f + (gettext (formatted-message-string obj) + %gettext-domain) + (formatted-message-arguments obj))) + (else + (report-error (G_ "exception thrown: ~s~%") obj)))) ((error args ...) (apply display-error #f (current-error-port) args)) (what? #f)) |