* Re: Linting, and how to get the information in to the Guix Data Serivce
2019-05-06 18:26 Linting, and how to get the information in to the Guix Data Serivce Christopher Baines
@ 2019-05-06 19:10 ` Christopher Baines
2019-05-07 21:16 ` Ludovic Courtès
0 siblings, 1 reply; 5+ messages in thread
From: Christopher Baines @ 2019-05-06 19:10 UTC (permalink / raw)
To: guix-devel
[-- Attachment #1.1: Type: text/plain, Size: 310 bytes --]
Christopher Baines <mail@cbaines.net> writes:
> I've never worked with this part of Guix before, and some of it is quite
> complex, so I've started by attempting to do the first bit, storing
> warnings as data before outputting them. I've attached a patch.
Now hopefuily with an actually attached patch...
[-- Attachment #1.2: Patch --]
[-- Type: text/x-patch, Size: 37809 bytes --]
From cd16443893afdacf9f3e4d8256cc943a5928aed4 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Mon, 6 May 2019 19:00:58 +0100
Subject: [PATCH] scripts: lint: Handle warnings with a record type.
Rather than emiting warnings directly to a port, have the checkers return the
warning or warnings.
This makes it easier to use the warnings in different ways, for example,
loading the data in to a database, as you can work with the <lint-warning>
records directly, rather than having to parse the output to determine the
package and location.
---
guix/scripts/lint.scm | 501 ++++++++++++++++++++++--------------------
1 file changed, 268 insertions(+), 233 deletions(-)
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index dc338a1d7b..878864030a 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -93,42 +93,65 @@
\f
;;;
-;;; Helpers
+;;; Warnings
;;;
-(define* (emit-warning package message #:optional field)
+
+(define-record-type* <lint-warning>
+ lint-warning make-lint-warning
+ lint-warning?
+ (package lint-warning-package)
+ (message lint-warning-message)
+ (location lint-warning-field
+ (default #f)))
+
+(define (package-file package)
+ (location-file
+ (package-location package)))
+
+(define* (make-warning package message
+ #:key field location)
+ (make-lint-warning
+ package
+ message
+ (or location
+ (package-field-location package field)
+ (package-location package))))
+
+(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.
- (let ((loc (or (package-field-location package field)
- (package-location package))))
- (format (guix-warning-port) "~a: ~a@~a: ~a~%"
- (location->string loc)
- (package-name package) (package-version package)
- message)))
-
-(define (call-with-accumulated-warnings thunk)
- "Call THUNK, accumulating any warnings in the current state, using the state
-monad."
- (let ((port (open-output-string)))
- (mlet %state-monad ((state (current-state))
- (result -> (parameterize ((guix-warning-port port))
- (thunk)))
- (warning -> (get-output-string port)))
- (mbegin %state-monad
- (munless (string=? "" warning)
- (set-current-state (cons warning state)))
- (return result)))))
-
-(define-syntax-rule (with-accumulated-warnings exp ...)
- "Evaluate EXP and accumulate warnings in the state monad."
- (call-with-accumulated-warnings
- (lambda ()
- exp ...)))
+ (for-each
+ (match-lambda
+ (($ <lint-warning> package message loc)
+ (format (guix-warning-port) "~a: ~a@~a: ~a~%"
+ (location->string loc)
+ (package-name package) (package-version package)
+ message)))
+ (match warnings
+ ((? lint-warning?) (list warnings))
+ ((? list?) (apply append-warnings warnings))
+ (_ '()))))
+
+(define (append-warnings . args)
+ (fold (lambda (arg warnings)
+ (cond
+ ((list? arg)
+ (append warnings
+ (filter lint-warning?
+ arg)))
+ ((lint-warning? arg)
+ (append warnings
+ (list arg)))
+ (else warnings)))
+ '()
+ args))
\f
;;;
;;; Checkers
;;;
+
(define-record-type* <lint-checker>
lint-checker make-lint-checker
lint-checker?
@@ -164,9 +187,9 @@ monad."
;; Emit a warning if stylistic issues are found in the description of PACKAGE.
(define (check-not-empty description)
(when (string-null? description)
- (emit-warning package
+ (make-warning package
(G_ "description should not be empty")
- 'description)))
+ #:field 'description)))
(define (check-texinfo-markup description)
"Check that DESCRIPTION can be parsed as a Texinfo fragment. If the
@@ -174,39 +197,38 @@ markup is valid return a plain-text version of DESCRIPTION, otherwise #f."
(catch #t
(lambda () (texi->plain-text description))
(lambda (keys . args)
- (emit-warning package
+ (make-warning package
(G_ "Texinfo markup in description is invalid")
- 'description)
- #f)))
+ #:field 'description))))
(define (check-trademarks description)
"Check that DESCRIPTION does not contain '™' or '®' characters. See
http://www.gnu.org/prep/standards/html_node/Trademarks.html."
(match (string-index description (char-set #\™ #\®))
((and (? number?) index)
- (emit-warning package
+ (make-warning package
(format #f (G_ "description should not contain ~
trademark sign '~a' at ~d")
(string-ref description index) index)
- 'description))
+ #:field 'description))
(else #t)))
(define (check-quotes description)
"Check whether DESCRIPTION contains single quotes and suggest @code."
(when (regexp-exec %quoted-identifier-rx description)
- (emit-warning package
-
+ (make-warning package
;; TRANSLATORS: '@code' is Texinfo markup and must be kept
;; as is.
(G_ "use @code or similar ornament instead of quotes")
- 'description)))
+ #:field 'description)))
(define (check-proper-start description)
(unless (or (properly-starts-sentence? description)
(string-prefix-ci? (package-name package) description))
- (emit-warning package
- (G_ "description should start with an upper-case letter or digit")
- 'description)))
+ (make-warning
+ package
+ (G_ "description should start with an upper-case letter or digit")
+ #:field 'description)))
(define (check-end-of-sentence-space description)
"Check that an end-of-sentence period is followed by two spaces."
@@ -220,27 +242,30 @@ trademark sign '~a' at ~d")
'("i.e" "e.g" "a.k.a" "resp"))
r (cons (match:start m) r)))))))
(unless (null? infractions)
- (emit-warning package
+ (make-warning package
(format #f (G_ "sentences in description should be followed ~
by two spaces; possible infraction~p at ~{~a~^, ~}")
(length infractions)
infractions)
- 'description))))
+ #:field 'description))))
(let ((description (package-description package)))
(if (string? description)
- (begin
- (check-not-empty description)
- (check-quotes description)
- (check-trademarks description)
- ;; Use raw description for this because Texinfo rendering
- ;; automatically fixes end of sentence space.
- (check-end-of-sentence-space description)
- (and=> (check-texinfo-markup description)
- check-proper-start))
- (emit-warning package
+ (append-warnings
+ (check-not-empty description)
+ (check-quotes description)
+ (check-trademarks description)
+ ;; Use raw description for this because Texinfo rendering
+ ;; automatically fixes end of sentence space.
+ (check-end-of-sentence-space description)
+ (and=> (check-texinfo-markup description)
+ (match-lambda
+ ((and warning (? lint-warning?)) warning)
+ (description
+ (check-proper-start description)))))
+ (make-warning package
(format #f (G_ "invalid description: ~s") description)
- 'description))))
+ #:field 'description))))
(define (package-input-intersection inputs-to-check input-names)
"Return the intersection between INPUTS-TO-CHECK, the list of input tuples
@@ -281,13 +306,13 @@ of a package, and INPUT-NAMES, a list of package specifications such as
"python-pytest-cov" "python2-pytest-cov"
"python-setuptools-scm" "python2-setuptools-scm"
"python-sphinx" "python2-sphinx")))
- (for-each (lambda (input)
- (emit-warning
- package
- (format #f (G_ "'~a' should probably be a native input")
- input)
- 'inputs-to-check))
- (package-input-intersection inputs input-names))))
+ (map (lambda (input)
+ (make-warning
+ package
+ (format #f (G_ "'~a' should probably be a native input")
+ input)
+ #:field 'inputs))
+ (package-input-intersection inputs input-names))))
(define (check-inputs-should-not-be-an-input-at-all package)
;; Emit a warning if some inputs of PACKAGE are likely to should not be
@@ -296,14 +321,15 @@ of a package, and INPUT-NAMES, a list of package specifications such as
"python2-setuptools"
"python-pip"
"python2-pip")))
- (for-each (lambda (input)
- (emit-warning
- package
- (format #f
- (G_ "'~a' should probably not be an input at all")
- input)))
- (package-input-intersection (package-direct-inputs package)
- input-names))))
+ (map (lambda (input)
+ (make-warning
+ package
+ (format #f
+ (G_ "'~a' should probably not be an input at all")
+ input)
+ #:field 'inputs))
+ (package-input-intersection (package-direct-inputs package)
+ input-names))))
(define (package-name-regexp package)
"Return a regexp that matches PACKAGE's name as a word at the beginning of a
@@ -316,17 +342,17 @@ line."
;; Emit a warning if stylistic issues are found in the synopsis of PACKAGE.
(define (check-not-empty synopsis)
(when (string-null? synopsis)
- (emit-warning package
+ (make-warning package
(G_ "synopsis should not be empty")
- 'synopsis)))
+ #:field 'synopsis)))
(define (check-final-period synopsis)
;; Synopsis should not end with a period, except for some special cases.
(when (and (string-suffix? "." synopsis)
(not (string-suffix? "etc." synopsis)))
- (emit-warning package
+ (make-warning package
(G_ "no period allowed at the end of the synopsis")
- 'synopsis)))
+ #:field 'synopsis)))
(define check-start-article
;; Skip this check for GNU packages, as suggested by Karl Berry's reply to
@@ -336,29 +362,29 @@ line."
(lambda (synopsis)
(when (or (string-prefix-ci? "A " synopsis)
(string-prefix-ci? "An " synopsis))
- (emit-warning package
+ (make-warning package
(G_ "no article allowed at the beginning of \
the synopsis")
- 'synopsis)))))
+ #:field 'synopsis)))))
(define (check-synopsis-length synopsis)
(when (>= (string-length synopsis) 80)
- (emit-warning package
+ (make-warning package
(G_ "synopsis should be less than 80 characters long")
- 'synopsis)))
+ #:field 'synopsis)))
(define (check-proper-start synopsis)
(unless (properly-starts-sentence? synopsis)
- (emit-warning package
+ (make-warning package
(G_ "synopsis should start with an upper-case letter or digit")
- 'synopsis)))
+ #:field 'synopsis)))
(define (check-start-with-package-name synopsis)
(when (and (regexp-exec (package-name-regexp package) synopsis)
(not (starts-with-abbreviation? synopsis)))
- (emit-warning package
+ (make-warning package
(G_ "synopsis should not start with the package name")
- 'synopsis)))
+ #:field 'synopsis)))
(define (check-texinfo-markup synopsis)
"Check that SYNOPSIS can be parsed as a Texinfo fragment. If the
@@ -366,10 +392,9 @@ markup is valid return a plain-text version of SYNOPSIS, otherwise #f."
(catch #t
(lambda () (texi->plain-text synopsis))
(lambda (keys . args)
- (emit-warning package
+ (make-warning package
(G_ "Texinfo markup in synopsis is invalid")
- 'synopsis)
- #f)))
+ #:field 'synopsis))))
(define checks
(list check-not-empty
@@ -382,12 +407,13 @@ markup is valid return a plain-text version of SYNOPSIS, otherwise #f."
(match (package-synopsis package)
((? string? synopsis)
- (for-each (lambda (proc)
- (proc synopsis))
- checks))
+ (apply append-warnings
+ (map (lambda (proc)
+ (proc synopsis))
+ checks)))
(invalid
- (emit-warning package (format #f (G_ "invalid synopsis: ~s") invalid)
- 'synopsis))))
+ (make-warning package (format #f (G_ "invalid synopsis: ~s") invalid)
+ #:field 'synopsis))))
(define* (probe-uri uri #:key timeout)
"Probe URI, a URI object, and return two values: a symbol denoting the
@@ -502,71 +528,66 @@ warning for PACKAGE mentionning the FIELD."
;; with a small HTML page upon failure. Attempt to detect
;; such malicious behavior.
(or (> length 1000)
- (begin
- (emit-warning package
- (format #f
- (G_ "URI ~a returned \
+ (make-warning package
+ (format #f
+ (G_ "URI ~a returned \
suspiciously small file (~a bytes)")
- (uri->string uri)
- length))
- #f)))
+ (uri->string uri)
+ length)
+ #:field field)))
(_ #t)))
((= 301 (response-code argument))
(if (response-location argument)
- (begin
- (emit-warning package
- (format #f (G_ "permanent redirect from ~a to ~a")
- (uri->string uri)
- (uri->string
- (response-location argument))))
- #t)
- (begin
- (emit-warning package
- (format #f (G_ "invalid permanent redirect \
+ (make-warning package
+ (format #f (G_ "permanent redirect from ~a to ~a")
+ (uri->string uri)
+ (uri->string
+ (response-location argument)))
+ #:field field)
+ (make-warning package
+ (format #f (G_ "invalid permanent redirect \
from ~a")
- (uri->string uri)))
- #f)))
+ (uri->string uri))
+ #:field)))
(else
- (emit-warning package
+ (make-warning package
(format #f
(G_ "URI ~a not reachable: ~a (~s)")
(uri->string uri)
(response-code argument)
(response-reason-phrase argument))
- field)
- #f)))
+ #:field field))))
((ftp-response)
(match argument
(('ok) #t)
(('error port command code message)
- (emit-warning package
+ (make-warning package
(format #f
(G_ "URI ~a not reachable: ~a (~s)")
(uri->string uri)
- code (string-trim-both message)))
- #f)))
+ code (string-trim-both message))
+ #:field field))))
((getaddrinfo-error)
- (emit-warning package
+ (make-warning package
(format #f
(G_ "URI ~a domain not found: ~a")
(uri->string uri)
(gai-strerror (car argument)))
- field)
- #f)
+ #:field field))
((system-error)
- (emit-warning package
+ (make-warning package
(format #f
(G_ "URI ~a unreachable: ~a")
(uri->string uri)
(strerror
(system-error-errno
(cons status argument))))
- field)
- #f)
+ #:field field))
((tls-certificate-error)
- (emit-warning package
+ (make-warning package
(format #f (G_ "TLS certificate error: ~a")
- (tls-certificate-error-string argument))))
+ (tls-certificate-error-string argument))
+ #:field field))
((invalid-http-response gnutls-error)
;; Probably a misbehaving server; ignore.
#f)
@@ -585,13 +606,13 @@ from ~a")
((not (package-home-page package))
(unless (or (string-contains (package-name package) "bootstrap")
(string=? (package-name package) "ld-wrapper"))
- (emit-warning package
+ (make-warning package
(G_ "invalid value for home page")
- 'home-page)))
+ #:field 'home-page)))
(else
- (emit-warning package (format #f (G_ "invalid home page URL: ~s")
+ (make-warning package (format #f (G_ "invalid home page URL: ~s")
(package-home-page package))
- 'home-page)))))
+ #:field 'home-page)))))
(define %distro-directory
(mlambda ()
@@ -601,42 +622,43 @@ from ~a")
"Emit a warning if the patches requires by PACKAGE are badly named or if the
patch could not be found."
(guard (c ((message-condition? c) ;raised by 'search-patch'
- (emit-warning package (condition-message c)
- 'patch-file-names)))
+ (make-warning package (condition-message c)
+ #:field 'patch-file-names)))
(define patches
(or (and=> (package-source package) origin-patches)
'()))
- (unless (every (match-lambda ;patch starts with package name?
+ (cons*
+ (unless (every (match-lambda ;patch starts with package name?
+ ((? string? patch)
+ (and=> (string-contains (basename patch)
+ (package-name package))
+ zero?))
+ (_ #f)) ;must be an <origin> or something like that.
+ patches)
+ (make-warning
+ package
+ (G_ "file names of patches should start with the package name")
+ #:field 'patch-file-names))
+
+ ;; Check whether we're reaching tar's maximum file name length.
+ (let ((prefix (string-length (%distro-directory)))
+ (margin (string-length "guix-0.13.0-10-123456789/"))
+ (max 99))
+ (filter-map (match-lambda
((? string? patch)
- (and=> (string-contains (basename patch)
- (package-name package))
- zero?))
- (_ #f)) ;must be an <origin> or something like that.
- patches)
- (emit-warning
- package
- (G_ "file names of patches should start with the package name")
- 'patch-file-names))
-
- ;; Check whether we're reaching tar's maximum file name length.
- (let ((prefix (string-length (%distro-directory)))
- (margin (string-length "guix-0.13.0-10-123456789/"))
- (max 99))
- (for-each (match-lambda
- ((? string? patch)
- (when (> (+ margin (if (string-prefix? (%distro-directory)
- patch)
- (- (string-length patch) prefix)
- (string-length patch)))
- max)
- (emit-warning
- package
- (format #f (G_ "~a: file name is too long")
- (basename patch))
- 'patch-file-names)))
- (_ #f))
- patches))))
+ (when (> (+ margin (if (string-prefix? (%distro-directory)
+ patch)
+ (- (string-length patch) prefix)
+ (string-length patch)))
+ max)
+ (make-warning
+ package
+ (format #f (G_ "~a: file name is too long")
+ (basename patch))
+ #:field 'patch-file-names)))
+ (_ #f))
+ patches)))))
(define (escape-quotes str)
"Replace any quote character in STR by an escaped quote character."
@@ -665,30 +687,29 @@ descriptions maintained upstream."
(#f ;not a GNU package, so nothing to do
#t)
(descriptor ;a genuine GNU package
- (let ((upstream (gnu-package-doc-summary descriptor))
- (downstream (package-synopsis package))
- (loc (or (package-field-location package 'synopsis)
- (package-location package))))
- (when (and upstream
- (or (not (string? downstream))
- (not (string=? upstream downstream))))
- (format (guix-warning-port)
- (G_ "~a: ~a: proposed synopsis: ~s~%")
- (location->string loc) (package-full-name package)
- upstream)))
-
- (let ((upstream (gnu-package-doc-description descriptor))
- (downstream (package-description package))
- (loc (or (package-field-location package 'description)
- (package-location package))))
- (when (and upstream
- (or (not (string? downstream))
- (not (string=? (fill-paragraph upstream 100)
- (fill-paragraph downstream 100)))))
- (format (guix-warning-port)
- (G_ "~a: ~a: proposed description:~% \"~a\"~%")
- (location->string loc) (package-full-name package)
- (fill-paragraph (escape-quotes upstream) 77 7)))))))
+ (list
+ (let ((upstream (gnu-package-doc-summary descriptor))
+ (downstream (package-synopsis package)))
+ (when (and upstream
+ (or (not (string? downstream))
+ (not (string=? upstream downstream))))
+ (make-warning package
+ (format #f (G_ "proposed synopsis: ~s~%")
+ upstream)
+ #:field 'synopsis)))
+
+ (let ((upstream (gnu-package-doc-description descriptor))
+ (downstream (package-description package)))
+ (when (and upstream
+ (or (not (string? downstream))
+ (not (string=? (fill-paragraph upstream 100)
+ (fill-paragraph downstream 100)))))
+ (make-warning
+ package
+ (format #f
+ (G_ "proposed description:~% \"~a\"~%")
+ (fill-paragraph (escape-quotes upstream) 77 7))
+ #:field 'description)))))))
(define (origin-uris origin)
"Return the list of URIs (strings) for ORIGIN."
@@ -701,38 +722,34 @@ descriptions maintained upstream."
(define (check-source package)
"Emit a warning if PACKAGE has an invalid 'source' field, or if that
'source' is not reachable."
- (define (try-uris uris)
- (run-with-state
- (anym %state-monad
- (lambda (uri)
- (with-accumulated-warnings
- (validate-uri uri package 'source)))
- (append-map (cut maybe-expand-mirrors <> %mirrors)
- uris))
- '()))
+ (define (warnings-for-uris uris)
+ (apply
+ append-warnings
+ (map
+ (lambda (uri)
+ (validate-uri uri package 'source))
+ (append-map (cut maybe-expand-mirrors <> %mirrors)
+ uris))))
(let ((origin (package-source package)))
(when (and origin
(eqv? (origin-method origin) url-fetch))
- (let ((uris (map string->uri (origin-uris origin))))
+ (let* ((uris (map string->uri (origin-uris origin)))
+ (warnings (warnings-for-uris uris)))
;; Just make sure that at least one of the URIs is valid.
- (call-with-values
- (lambda () (try-uris uris))
- (lambda (success? warnings)
+ (if (eq? (length uris) (length warnings))
;; When everything fails, report all of WARNINGS, otherwise don't
;; report anything.
;;
;; XXX: Ideally we'd still allow warnings to be raised if *some*
;; URIs are unreachable, but distinguish that from the error case
;; where *all* the URIs are unreachable.
- (unless success?
- (emit-warning package
- (G_ "all the source URIs are unreachable:")
- 'source)
- (for-each (lambda (warning)
- (display warning (guix-warning-port)))
- (reverse warnings)))))))))
+ (cons*
+ (make-warning package
+ (G_ "all the source URIs are unreachable:")
+ #:field 'source)
+ warnings))))))
(define (check-source-file-name package)
"Emit a warning if PACKAGE's origin has no meaningful file name."
@@ -749,9 +766,9 @@ descriptions maintained upstream."
(let ((origin (package-source package)))
(unless (or (not origin) (origin-file-name-valid? origin))
- (emit-warning package
+ (make-warning package
(G_ "the source file name should contain the package name")
- 'source))))
+ #:field 'source))))
(define (check-source-unstable-tarball package)
"Emit a warning if PACKAGE's source is an autogenerated tarball."
@@ -761,14 +778,14 @@ descriptions maintained upstream."
(uri-path (string->uri uri)))
((_ _ "archive" _ ...) #t)
(_ #f)))
- (emit-warning package
+ (make-warning package
(G_ "the source URI should not be an autogenerated tarball")
- 'source)))
+ #:field 'source)))
(let ((origin (package-source package)))
(when (and (origin? origin)
(eqv? (origin-method origin) url-fetch))
(let ((uris (origin-uris origin)))
- (for-each check-source-uri uris)))))
+ (filter-map check-source-uri uris)))))
(define (check-mirror-url package)
"Check whether PACKAGE uses source URLs that should be 'mirror://'."
@@ -782,18 +799,18 @@ descriptions maintained upstream."
(#f
(loop rest))
(prefix
- (emit-warning package
+ (make-warning package
(format #f (G_ "URL should be \
'mirror://~a/~a'")
mirror-id
(string-drop uri (string-length prefix)))
- 'source)))))))
+ #:field 'source)))))))
(let ((origin (package-source package)))
(when (and (origin? origin)
(eqv? (origin-method origin) url-fetch))
(let ((uris (origin-uris origin)))
- (for-each check-mirror-uri uris)))))
+ (filter-map check-mirror-uri uris)))))
(define* (check-github-url package #:key (timeout 3))
"Check whether PACKAGE uses source URLs that redirect to GitHub."
@@ -819,15 +836,15 @@ descriptions maintained upstream."
(let ((origin (package-source package)))
(when (and (origin? origin)
(eqv? (origin-method origin) url-fetch))
- (for-each
+ (filter-map
(lambda (uri)
(and=> (follow-redirects-to-github uri)
(lambda (github-uri)
(unless (string=? github-uri uri)
- (emit-warning
+ (make-warning
package
(format #f (G_ "URL should be '~a'") github-uri)
- 'source)))))
+ #:field 'source)))))
(origin-uris origin)))))
(define (check-derivation package)
@@ -836,12 +853,12 @@ descriptions maintained upstream."
(catch #t
(lambda ()
(guard (c ((store-protocol-error? c)
- (emit-warning package
+ (make-warning package
(format #f (G_ "failed to create ~a derivation: ~a")
system
(store-protocol-error-message c))))
((message-condition? c)
- (emit-warning package
+ (make-warning package
(format #f (G_ "failed to create ~a derivation: ~a")
system
(condition-message c)))))
@@ -858,11 +875,11 @@ descriptions maintained upstream."
(package-derivation store replacement system
#:graft? #f)))))))
(lambda args
- (emit-warning package
+ (make-warning package
(format #f (G_ "failed to create ~a derivation: ~s")
system args)))))
- (for-each try (package-supported-systems package)))
+ (filter-map try (package-supported-systems package)))
(define (check-license package)
"Warn about type errors of the 'license' field of PACKAGE."
@@ -871,8 +888,8 @@ descriptions maintained upstream."
((? license?) ...))
#t)
(x
- (emit-warning package (G_ "invalid license field")
- 'license))))
+ (make-warning package (G_ "invalid license field")
+ #:field 'license))))
(define (call-with-networking-fail-safe message error-value proc)
"Call PROC catching any network-related errors. Upon a networking error,
@@ -944,10 +961,10 @@ the NIST server non-fatal."
(member id known-safe))))
vulnerabilities)))
(unless (null? unpatched)
- (emit-warning package
- (format #f (G_ "probably vulnerable to ~a")
- (string-join (map vulnerability-id unpatched)
- ", ")))))))))
+ (make-warning package
+ (format #f (G_ "probably vulnerable to ~a")
+ (string-join (map vulnerability-id unpatched)
+ ", ")))))))))
(define (check-for-updates package)
"Check if there is an update available for PACKAGE."
@@ -959,9 +976,10 @@ the NIST server non-fatal."
((? upstream-source? source)
(when (version>? (upstream-source-version source)
(package-version package))
- (emit-warning package
+ (make-warning package
(format #f (G_ "can be upgraded to ~a")
- (upstream-source-version source)))))
+ (upstream-source-version source))
+ #:field 'version)))
(#f #f))) ; cannot find newer upstream release
\f
@@ -974,18 +992,26 @@ the NIST server non-fatal."
(match (string-index line #\tab)
(#f #t)
(index
- (emit-warning package
+ (make-warning package
(format #f (G_ "tabulation on line ~a, column ~a")
- line-number index)))))
+ line-number index)
+ #:location
+ (location (package-file package)
+ line-number
+ index)))))
(define (report-trailing-white-space package line line-number)
"Warn about trailing white space in LINE."
(unless (or (string=? line (string-trim-right line))
(string=? line (string #\page)))
- (emit-warning package
+ (make-warning package
(format #f
(G_ "trailing white space on line ~a")
- line-number))))
+ line-number)
+ #:location
+ (location (package-file package)
+ line-number
+ 0))))
(define (report-long-line package line line-number)
"Emit a warning if LINE is too long."
@@ -993,9 +1019,13 @@ the NIST server non-fatal."
;; make it hard to fit within that limit and we want to avoid making too
;; much noise.
(when (> (string-length line) 90)
- (emit-warning package
+ (make-warning package
(format #f (G_ "line ~a is way too long (~a characters)")
- line-number (string-length line)))))
+ line-number (string-length line))
+ #:location
+ (location (package-file package)
+ line-number
+ 0))))
(define %hanging-paren-rx
(make-regexp "^[[:blank:]]*[()]+[[:blank:]]*$"))
@@ -1003,11 +1033,15 @@ the NIST server non-fatal."
(define (report-lone-parentheses package line line-number)
"Emit a warning if LINE contains hanging parentheses."
(when (regexp-exec %hanging-paren-rx line)
- (emit-warning package
+ (make-warning package
(format #f
- (G_ "line ~a: parentheses feel lonely, \
+ (G_ "parentheses feel lonely, \
move to the previous or next line")
- line-number))))
+ line-number)
+ #:location
+ (location (package-file package)
+ line-number
+ 0))))
(define %formatting-reporters
;; List of procedures that report formatting issues. These are not separate
@@ -1155,7 +1189,8 @@ or a list thereof")
(package-name package) (package-version package)
(lint-checker-name checker))
(force-output (current-error-port)))
- ((lint-checker-check checker) package))
+ (emit-warnings
+ ((lint-checker-check checker) package)))
checkers)
(when tty?
(format (current-error-port) "\x1b[K")
--
2.21.0
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 962 bytes --]
^ permalink raw reply related [flat|nested] 5+ messages in thread