ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-06 23:16:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

diagnostics: Add '&formatted-message'.

Browse source 
This allows 'gettext' to be called on the format string at the site
where the exception is caught (rather than the site where it's thrown).
It also allows for argument highlighting.

* guix/diagnostics.scm (&formatted-message): New condition type.
(check-format-string): New procedure.
(formatted-message): New macro.
* guix/ui.scm (report-load-error): Add clause for 'formatted-message?'.
(warn-about-load-error): Likewise.
(call-with-error-handling): Likewise.
(read/eval): Likewise.
This commit is contained in:
Ludovic Courtès 2020-07-25 17:59:13 +02:00
parent 860f3d7749
commit 252a1926bc
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 110 additions and 17 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

65
guix/diagnostics.scm
View file

@ -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 @@ (define-module (guix diagnostics)
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 @@ (define-condition-type &fix-hint &condition
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)))

62
guix/ui.scm
View file

@ -388,12 +388,18 @@ (define* (report-load-error file args #:optional frame)
(('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 @@ (define (warn-about-load-error file module args) ;FIXME: factorize with ↑
(('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 @@ (define (manifest-entry-output* entry)
(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 @@ (define (read/eval str)
(('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))