Re: Linting, and how to get the information in to the Guix Data Serivce

[Christopher Baines <mail@cbaines.net>]

[-- 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 --]