;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
(define-module (guix diagnostics)
#:use-module (guix colors)
#:use-module (guix i18n)
- #:autoload (guix utils) (<location>)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-35)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:export (warning
report-error
leave
+ <location>
+ location
+ location?
+ location-file
+ location-line
+ location-column
+ source-properties->location
+ location->source-properties
location->string
+ &error-location
+ error-location?
+ error-location
+
+ formatted-message
+ formatted-message?
+ formatted-message-string
+ formatted-message-arguments
+
+ &fix-hint
+ fix-hint?
+ condition-fix-hint
+
guix-warning-port
program-name))
;;;
;;; Code:
+(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)))))))
+
(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.
args (... ...))
(free-identifier=? #'N-underscore #'N_)
#'(name #f (N-underscore singular plural n)
- args (... ...)))))))))
+ args (... ...)))
+ (id
+ (identifier? #'id)
+ ;; Run-time variant.
+ #'(lambda (location fmt . args)
+ (emit-diagnostic fmt args
+ #:location location
+ #:prefix prefix
+ #:colors colors)))))))))
;; XXX: This doesn't work well for right-to-left languages.
;; TRANSLATORS: The goal is to emit "warning:" followed by a short phrase;
(report-error args ...)
(exit 1)))
+(define* (emit-diagnostic fmt args
+ #:key location (colors (color)) (prefix ""))
+ "Report diagnostic message FMT with the given ARGS and the specified
+LOCATION, COLORS, and PREFIX.
+
+This procedure is used as a last resort when the format string is not known at
+macro-expansion time."
+ (print-diagnostic-prefix (gettext prefix %gettext-domain)
+ location #:colors colors)
+ (apply format (guix-warning-port) fmt
+ (if (trivial-format-string? fmt)
+ (map %highlight-argument args)
+ args)))
+
(define %warning-color (color BOLD MAGENTA))
(define %info-color (color BOLD))
(define %error-color (color BOLD RED))
(program-name) (program-name)
(prefix-color prefix)))))
+\f
+;; A source location.
+(define-record-type <location>
+ (make-location file line column)
+ location?
+ (file location-file) ; file name
+ (line location-line) ; 1-indexed line
+ (column location-column)) ; 0-indexed column
+
+(define (location file line column)
+ "Return the <location> object for the given FILE, LINE, and COLUMN."
+ (and line column file
+ (make-location file line column)))
+
+(define (source-properties->location loc)
+ "Return a location object based on the info in LOC, an alist as returned
+by Guile's `source-properties', `frame-source', `current-source-location',
+etc."
+ ;; In accordance with the GCS, start line and column numbers at 1. Note
+ ;; that unlike LINE and `port-column', COL is actually 1-indexed here...
+ (match loc
+ ((('line . line) ('column . col) ('filename . file)) ;common case
+ (and file line col
+ (make-location file (+ line 1) col)))
+ (#f
+ #f)
+ (_
+ (let ((file (assq-ref loc 'filename))
+ (line (assq-ref loc 'line))
+ (col (assq-ref loc 'column)))
+ (location file (and line (+ line 1)) col)))))
+
+(define (location->source-properties loc)
+ "Return the source property association list based on the info in LOC,
+a location object."
+ `((line . ,(and=> (location-line loc) 1-))
+ (column . ,(location-column loc))
+ (filename . ,(location-file loc))))
+
(define (location->string loc)
"Return a human-friendly, GNU-standard representation of LOC."
(match loc
(($ <location> file line column)
(format #f "~a:~a:~a" file line column))))
+(define-condition-type &error-location &error
+ error-location?
+ (location error-location)) ;<location>
+
+(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 ...))))))))))
+
\f
(define guix-warning-port
(make-parameter (current-warning-port)))
HCoop / jackhill / guix / guix.git / blobdiff