From: Christopher Baines <mail@cbaines.net>
To: 35790@debbugs.gnu.org
Subject: [bug#35790] [PATCH 2/4] scripts: lint: Separate the message warning text and data.
Date: Mon, 15 Jul 2019 20:45:56 +0100 [thread overview]
Message-ID: <20190715194558.13804-2-mail@cbaines.net> (raw)
In-Reply-To: <20190715194558.13804-1-mail@cbaines.net>
So that translations can be handled more flexibly, rather than having to
translate the message text within the checker.
* guix/scripts/lint.scm (lint-warning-message-text,
lint-warning-message-data): New procedures.
(lint-warning-message): Remove record field accessor, replace with procedure
that handles the lint warning data and translating the message.
(make-warning): Rename to %make-warning.
(make-warning): New macro.
(emit-warnings): Handle the message-text and message-data fields.
(check-description-style): Adjust for changes to make-warning.
[check-trademarks, check-end-of-sentence-space): Adjust for changes to
make-warning.
(check-inputs-should-be-native, check-inputs-should-not-be-an-input-at-all,
check-synopsis-style, validate-uri, check-home-page, check-patch-file-names,
check-gnu-synopsis+description, check-mirror-url, check-github-url,
check-derivation, check-vulnerabilities, check-for-updates,
report-tabulations, report-trailing-white-space, report-long-line,
report-lone-parentheses): Adjust for changes to make-warning.
---
guix/scripts/lint.scm | 198 ++++++++++++++++++++++--------------------
1 file changed, 106 insertions(+), 92 deletions(-)
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index 1b08068669..4eb7e0e200 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -88,6 +88,8 @@
lint-warning?
lint-warning-package
lint-warning-message
+ lint-warning-message-text
+ lint-warning-message-data
lint-warning-location
%checkers
@@ -105,35 +107,49 @@
(define-record-type* <lint-warning>
lint-warning make-lint-warning
lint-warning?
- (package lint-warning-package)
- (message lint-warning-message)
- (location lint-warning-location
- (default #f)))
+ (package lint-warning-package)
+ (message-text lint-warning-message-text)
+ (message-data lint-warning-message-data
+ (default '()))
+ (location lint-warning-location
+ (default #f)))
+
+(define (lint-warning-message warning)
+ (apply format #f
+ (G_ (lint-warning-message-text warning))
+ (lint-warning-message-data warning)))
(define (package-file package)
(location-file
(package-location package)))
-(define* (make-warning package message
- #:key field location)
+(define* (%make-warning package message-text
+ #:optional (message-data '())
+ #:key field location)
(make-lint-warning
package
- message
+ message-text
+ message-data
(or location
(package-field-location package field)
(package-location package))))
+(define-syntax make-warning
+ (syntax-rules (G_)
+ ((_ package (G_ message) rest ...)
+ (%make-warning package message rest ...))))
+
(define (emit-warnings warnings)
;; Emit a warning about PACKAGE, printing the location of FIELD if it is
;; given, the location of PACKAGE otherwise, the full name of PACKAGE and the
;; provided MESSAGE.
(for-each
(match-lambda
- (($ <lint-warning> package message loc)
+ (($ <lint-warning> package message-text message-data loc)
(format (guix-warning-port) "~a: ~a@~a: ~a~%"
(location->string loc)
(package-name package) (package-version package)
- message)))
+ (apply format #f (G_ message-text) message-data))))
warnings))
\f
@@ -199,9 +215,9 @@ http://www.gnu.org/prep/standards/html_node/Trademarks.html."
((and (? number?) index)
(list
(make-warning package
- (format #f (G_ "description should not contain ~
+ (G_ "description should not contain ~
trademark sign '~a' at ~d")
- (string-ref description index) index)
+ (list (string-ref description index) index)
#:field 'description)))
(else '())))
@@ -242,10 +258,10 @@ trademark sign '~a' at ~d")
'()
(list
(make-warning package
- (format #f (G_ "sentences in description should be followed ~
+ (G_ "sentences in description should be followed ~
by two spaces; possible infraction~p at ~{~a~^, ~}")
- (length infractions)
- infractions)
+ (list (length infractions)
+ infractions)
#:field 'description)))))
(let ((description (package-description package)))
@@ -263,7 +279,8 @@ by two spaces; possible infraction~p at ~{~a~^, ~}")
(check-proper-start plain-description))))
(list
(make-warning package
- (format #f (G_ "invalid description: ~s") description)
+ (G_ "invalid description: ~s")
+ (list description)
#:field 'description)))))
(define (package-input-intersection inputs-to-check input-names)
@@ -308,8 +325,8 @@ of a package, and INPUT-NAMES, a list of package specifications such as
(map (lambda (input)
(make-warning
package
- (format #f (G_ "'~a' should probably be a native input")
- input)
+ (G_ "'~a' should probably be a native input")
+ (list input)
#:field 'inputs))
(package-input-intersection inputs input-names))))
@@ -323,9 +340,8 @@ of a package, and INPUT-NAMES, a list of package specifications such as
(map (lambda (input)
(make-warning
package
- (format #f
- (G_ "'~a' should probably not be an input at all")
- input)
+ (G_ "'~a' should probably not be an input at all")
+ (list input)
#:field 'inputs))
(package-input-intersection (package-direct-inputs package)
input-names))))
@@ -423,7 +439,9 @@ markup is valid return a plain-text version of SYNOPSIS, otherwise #f."
checks))
(invalid
(list
- (make-warning package (format #f (G_ "invalid synopsis: ~s") invalid)
+ (make-warning package
+ (G_ "invalid synopsis: ~s")
+ (list invalid)
#:field 'synopsis)))))
(define* (probe-uri uri #:key timeout)
@@ -540,64 +558,59 @@ PACKAGE mentionning the FIELD."
;; such malicious behavior.
(or (> length 1000)
(make-warning package
- (format #f
- (G_ "URI ~a returned \
+ (G_ "URI ~a returned \
suspiciously small file (~a bytes)")
- (uri->string uri)
- length)
+ (list (uri->string uri)
+ length)
#:field field)))
(_ #t)))
((= 301 (response-code argument))
(if (response-location argument)
(make-warning package
- (format #f (G_ "permanent redirect from ~a to ~a")
- (uri->string uri)
- (uri->string
- (response-location argument)))
+ (G_ "permanent redirect from ~a to ~a")
+ (list (uri->string uri)
+ (uri->string
+ (response-location argument)))
#:field field)
(make-warning package
- (format #f (G_ "invalid permanent redirect \
+ (G_ "invalid permanent redirect \
from ~a")
- (uri->string uri))
+ (list (uri->string uri))
#:field field)))
(else
(make-warning package
- (format #f
- (G_ "URI ~a not reachable: ~a (~s)")
- (uri->string uri)
- (response-code argument)
- (response-reason-phrase argument))
+ (G_ "URI ~a not reachable: ~a (~s)")
+ (list (uri->string uri)
+ (response-code argument)
+ (response-reason-phrase argument))
#:field field))))
((ftp-response)
(match argument
(('ok) #t)
(('error port command code message)
(make-warning package
- (format #f
- (G_ "URI ~a not reachable: ~a (~s)")
- (uri->string uri)
- code (string-trim-both message))
+ (G_ "URI ~a not reachable: ~a (~s)")
+ (list (uri->string uri)
+ code (string-trim-both message))
#:field field))))
((getaddrinfo-error)
(make-warning package
- (format #f
- (G_ "URI ~a domain not found: ~a")
- (uri->string uri)
- (gai-strerror (car argument)))
+ (G_ "URI ~a domain not found: ~a")
+ (list (uri->string uri)
+ (gai-strerror (car argument)))
#:field field))
((system-error)
(make-warning package
- (format #f
- (G_ "URI ~a unreachable: ~a")
- (uri->string uri)
- (strerror
- (system-error-errno
- (cons status argument))))
+ (G_ "URI ~a unreachable: ~a")
+ (list (uri->string uri)
+ (strerror
+ (system-error-errno
+ (cons status argument))))
#:field field))
((tls-certificate-error)
(make-warning package
- (format #f (G_ "TLS certificate error: ~a")
- (tls-certificate-error-string argument))
+ (G_ "TLS certificate error: ~a")
+ (list (tls-certificate-error-string argument))
#:field field))
((invalid-http-response gnutls-error)
;; Probably a misbehaving server; ignore.
@@ -627,8 +640,9 @@ from ~a")
#:field 'home-page))))
(else
(list
- (make-warning package (format #f (G_ "invalid home page URL: ~s")
- (package-home-page package))
+ (make-warning package
+ (G_ "invalid home page URL: ~s")
+ (list (package-home-page package))
#:field 'home-page))))))
(define %distro-directory
@@ -640,8 +654,10 @@ from ~a")
patch could not be found."
(guard (c ((message-condition? c) ;raised by 'search-patch'
(list
- (make-warning package (condition-message c)
- #:field 'patch-file-names))))
+ ;; Use %make-warning, as condition-mesasge is already
+ ;; translated.
+ (%make-warning package (condition-message c)
+ #:field 'patch-file-names))))
(define patches
(or (and=> (package-source package) origin-patches)
'()))
@@ -674,8 +690,8 @@ patch could not be found."
max)
(make-warning
package
- (format #f (G_ "~a: file name is too long")
- (basename patch))
+ (G_ "~a: file name is too long")
+ (list (basename patch))
#:field 'patch-file-names)
#f))
(_ #f))
@@ -716,8 +732,8 @@ descriptions maintained upstream."
(not (string=? upstream downstream))))
(list
(make-warning package
- (format #f (G_ "proposed synopsis: ~s~%")
- upstream)
+ (G_ "proposed synopsis: ~s~%")
+ (list upstream)
#:field 'synopsis))
'()))
@@ -730,9 +746,8 @@ descriptions maintained upstream."
(list
(make-warning
package
- (format #f
- (G_ "proposed description:~% \"~a\"~%")
- (fill-paragraph (escape-quotes upstream) 77 7))
+ (G_ "proposed description:~% \"~a\"~%")
+ (list (fill-paragraph (escape-quotes upstream) 77 7))
#:field 'description))
'()))))))
@@ -831,10 +846,10 @@ descriptions maintained upstream."
(loop rest))
(prefix
(make-warning package
- (format #f (G_ "URL should be \
+ (G_ "URL should be \
'mirror://~a/~a'")
- mirror-id
- (string-drop uri (string-length prefix)))
+ (list mirror-id
+ (string-drop uri (string-length prefix)))
#:field 'source)))))))
(let ((origin (package-source package)))
@@ -876,7 +891,8 @@ descriptions maintained upstream."
#f
(make-warning
package
- (format #f (G_ "URL should be '~a'") github-uri)
+ (G_ "URL should be '~a'")
+ (list github-uri)
#:field 'source)))))
(origin-uris origin))
'())))
@@ -888,14 +904,14 @@ descriptions maintained upstream."
(lambda ()
(guard (c ((store-protocol-error? c)
(make-warning package
- (format #f (G_ "failed to create ~a derivation: ~a")
- system
- (store-protocol-error-message c))))
+ (G_ "failed to create ~a derivation: ~a")
+ (list system
+ (store-protocol-error-message c))))
((message-condition? c)
(make-warning package
- (format #f (G_ "failed to create ~a derivation: ~a")
- system
- (condition-message c)))))
+ (G_ "failed to create ~a derivation: ~a")
+ (list system
+ (condition-message c)))))
(with-store store
;; Disable grafts since it can entail rebuilds.
(parameterize ((%graft? #f))
@@ -910,8 +926,8 @@ descriptions maintained upstream."
#:graft? #f)))))))
(lambda args
(make-warning package
- (format #f (G_ "failed to create ~a derivation: ~s")
- system args)))))
+ (G_ "failed to create ~a derivation: ~s")
+ (list system args)))))
(filter lint-warning?
(map try (package-supported-systems package))))
@@ -1001,15 +1017,15 @@ the NIST server non-fatal."
(list
(make-warning
package
- (format #f (G_ "probably vulnerable to ~a")
- (string-join (map vulnerability-id unpatched)
- ", "))))))))))
+ (G_ "probably vulnerable to ~a")
+ (list (string-join (map vulnerability-id unpatched)
+ ", "))))))))))
(define (check-for-updates package)
"Check if there is an update available for PACKAGE."
(match (with-networking-fail-safe
- (format #f (G_ "while retrieving upstream info for '~a'")
- (package-name package))
+ (G_ "while retrieving upstream info for '~a'")
+ (list (package-name package))
#f
(package-latest-release* package (force %updaters)))
((? upstream-source? source)
@@ -1017,8 +1033,8 @@ the NIST server non-fatal."
(package-version package))
(list
(make-warning package
- (format #f (G_ "can be upgraded to ~a")
- (upstream-source-version source))
+ (G_ "can be upgraded to ~a")
+ (list (upstream-source-version source))
#:field 'version))
'()))
(#f '()))) ; cannot find newer upstream release
@@ -1034,8 +1050,8 @@ the NIST server non-fatal."
(#f #t)
(index
(make-warning package
- (format #f (G_ "tabulation on line ~a, column ~a")
- line-number index)
+ (G_ "tabulation on line ~a, column ~a")
+ (list line-number index)
#:location
(location (package-file package)
line-number
@@ -1046,9 +1062,8 @@ the NIST server non-fatal."
(unless (or (string=? line (string-trim-right line))
(string=? line (string #\page)))
(make-warning package
- (format #f
- (G_ "trailing white space on line ~a")
- line-number)
+ (G_ "trailing white space on line ~a")
+ (list line-number)
#:location
(location (package-file package)
line-number
@@ -1061,8 +1076,8 @@ the NIST server non-fatal."
;; much noise.
(when (> (string-length line) 90)
(make-warning package
- (format #f (G_ "line ~a is way too long (~a characters)")
- line-number (string-length line))
+ (G_ "line ~a is way too long (~a characters)")
+ (list line-number (string-length line))
#:location
(location (package-file package)
line-number
@@ -1075,10 +1090,9 @@ the NIST server non-fatal."
"Emit a warning if LINE contains hanging parentheses."
(when (regexp-exec %hanging-paren-rx line)
(make-warning package
- (format #f
- (G_ "parentheses feel lonely, \
+ (G_ "parentheses feel lonely, \
move to the previous or next line")
- line-number)
+ (list line-number)
#:location
(location (package-file package)
line-number
--
2.22.0
next prev parent reply other threads:[~2019-07-15 19:47 UTC|newest]
Thread overview: 37+ messages / expand[flat|nested] mbox.gz Atom feed top
2019-05-18 9:32 [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type Christopher Baines
2019-05-21 14:41 ` Ludovic Courtès
2019-06-01 18:31 ` Christopher Baines
2019-06-07 7:44 ` Ludovic Courtès
2019-06-16 13:00 ` Christopher Baines
2019-06-20 11:40 ` Ludovic Courtès
2019-06-01 19:09 ` Christopher Baines
2019-06-07 7:38 ` Ludovic Courtès
2019-06-16 12:56 ` [bug#35790] [PATCH] scripts: lint: Separate the message warning text and data Christopher Baines
2019-06-24 8:36 ` Ludovic Courtès
2019-06-29 8:46 ` Christopher Baines
2019-06-16 13:05 ` [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type Christopher Baines
2019-06-20 11:49 ` Ludovic Courtès
2019-06-24 6:46 ` Christopher Baines
2019-06-24 8:33 ` Ludovic Courtès
2019-06-24 8:39 ` Ludovic Courtès
2019-06-29 11:25 ` [bug#35790] [PATCH 1/2] " Christopher Baines
2019-06-29 11:25 ` [bug#35790] [PATCH 2/2] scripts: lint: Separate the message warning text and data Christopher Baines
2019-06-29 11:56 ` [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type Christopher Baines
2019-07-01 12:32 ` Ludovic Courtès
2019-07-02 19:25 ` [bug#35790] [PATCH 1/2] lint: Move the linting code to a different module Christopher Baines
2019-07-02 19:25 ` [bug#35790] [PATCH 2/2] lint: Separate checkers by dependence on the internet Christopher Baines
2019-07-12 14:38 ` Ludovic Courtès
2019-07-14 18:17 ` Christopher Baines
2019-07-12 14:36 ` [bug#35790] [PATCH 1/2] lint: Move the linting code to a different module Ludovic Courtès
2019-07-14 18:03 ` Christopher Baines
2019-07-14 18:23 ` Christopher Baines
2019-07-15 9:20 ` Ludovic Courtès
2019-07-15 19:45 ` [bug#35790] [PATCH 1/4] scripts: lint: Handle warnings with a record type Christopher Baines
2019-07-15 19:45 ` Christopher Baines [this message]
2019-07-15 19:45 ` [bug#35790] [PATCH 3/4] lint: Move the linting code to a different module Christopher Baines
2019-07-15 19:45 ` [bug#35790] [PATCH 4/4] lint: Separate checkers by dependence on the internet Christopher Baines
2019-07-15 20:17 ` Ludovic Courtès
2019-07-15 22:23 ` bug#35790: " Christopher Baines
2019-07-16 21:34 ` [bug#35790] " Ludovic Courtès
2019-07-15 19:51 ` [bug#35790] [PATCH 1/2] lint: Move the linting code to a different module Christopher Baines
2019-07-02 20:15 ` [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type Christopher Baines
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://guix.gnu.org/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20190715194558.13804-2-mail@cbaines.net \
--to=mail@cbaines.net \
--cc=35790@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).