gnu: r-qtl2: Move to (gnu packages cran).

[jackhill/guix/guix.git] / guix / lint.scm

diff --git a/guix/lint.scm b/guix/lint.scm
index fa50754..ec43a4d 100644 (file)
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -139,7 +139,7 @@
    message-text
    message-data
    (or location
-       (package-field-location package field)
+       (and field (package-field-location package field))
        (package-location package))))
 
 (define-syntax make-warning
@@ -668,10 +668,16 @@ patch could not be found."
               ;; Use %make-warning, as condition-mesasge is already
               ;; translated.
               (%make-warning package (condition-message c)
-                             #:field 'patch-file-names))))
+                             #:field 'patch-file-names)))
+            ((formatted-message? c)
+             (list (%make-warning package
+                                  (apply format #f
+                                         (G_ (formatted-message-string c))
+                                         (formatted-message-arguments c))))))
     (define patches
-      (or (and=> (package-source package) origin-patches)
-          '()))
+      (match (package-source package)
+        ((? origin? origin) (origin-patches origin))
+        (_ '())))
 
     (define (starts-with-package-name? file-name)
       (and=> (string-contains file-name (package-name package))
@@ -788,30 +794,39 @@ descriptions maintained upstream."
            (#t
             ;; We found a working URL, so stop right away.
             '())
+           (#f
+            ;; Unsupported URL or other error, skip.
+            (loop rest warnings))
            ((? lint-warning? warning)
             (loop rest (cons warning warnings))))))))
 
   (let ((origin (package-source package)))
-    (if (and origin
-             (eqv? (origin-method origin) url-fetch))
-        (let* ((uris     (append-map (cut maybe-expand-mirrors <> %mirrors)
-                                     (map string->uri (origin-uris origin))))
-               (warnings (warnings-for-uris uris)))
-
-          ;; Just make sure that at least one of the URIs is valid.
-          (if (= (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.
-              (cons*
-               (make-warning package
-                             (G_ "all the source URIs are unreachable:")
-                             #:field 'source)
-               warnings)
-              '()))
+    (if (origin? origin)
+        (cond
+         ((eq? (origin-method origin) url-fetch)
+          (let* ((uris     (append-map (cut maybe-expand-mirrors <> %mirrors)
+                                       (map string->uri (origin-uris origin))))
+                 (warnings (warnings-for-uris uris)))
+
+            ;; Just make sure that at least one of the URIs is valid.
+            (if (= (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.
+                (cons*
+                 (make-warning package
+                               (G_ "all the source URIs are unreachable:")
+                               #:field 'source)
+                 warnings)
+                '())))
+         ((git-reference? (origin-uri origin))
+          (warnings-for-uris
+           (list (string->uri (git-reference-url (origin-uri origin))))))
+         (else
+          '()))
         '())))
 
 (define (check-source-file-name package)
@@ -828,7 +843,7 @@ descriptions maintained upstream."
            (not (string-match (string-append "^v?" version) file-name)))))
 
   (let ((origin (package-source package)))
-    (if (or (not origin) (origin-file-name-valid? origin))
+    (if (or (not (origin? origin)) (origin-file-name-valid? origin))
         '()
         (list
          (make-warning package
@@ -948,7 +963,14 @@ descriptions maintained upstream."
                    (make-warning package
                                  (G_ "failed to create ~a derivation: ~a")
                                  (list system
-                                       (condition-message c)))))
+                                       (condition-message c))))
+                  ((formatted-message? c)
+                   (let ((str (apply format #f
+                                     (formatted-message-string c)
+                                     (formatted-message-arguments c))))
+                     (make-warning package
+                                   (G_ "failed to create ~a derivation: ~a")
+                                   (list system str)))))
           (parameterize ((%graft? #f))
             (package-derivation store package system #:graft? #f)
 
@@ -1208,7 +1230,7 @@ Heritage")
                     '())))
                '()))))
       (match-lambda*
-        ((key url method response)
+        (('swh-error url method response)
          (response->warning url method response))
         ((key . args)
          (if (eq? key skip-key)
@@ -1333,12 +1355,20 @@ them for PACKAGE."
   "Check the formatting of the source code of PACKAGE."
   (let ((location (package-location package)))
     (if location
-        (and=> (search-path %load-path (location-file location))
-               (lambda (file)
-                 ;; Report issues starting from the line before the 'package'
-                 ;; form, which usually contains the 'define' form.
-                 (report-formatting-issues package file
-                                           (- (location-line location) 1))))
+        ;; Report issues starting from the line before the 'package'
+        ;; form, which usually contains the 'define' form.
+        (let ((line (- (location-line location) 1)))
+          (match (search-path %load-path (location-file location))
+            ((? string? file)
+             (report-formatting-issues package file line))
+            (#f
+             ;; It could be that LOCATION lists a "true" relative file
+             ;; name--i.e., not relative to an element of %LOAD-PATH.
+             (let ((file (location-file location)))
+               (if (file-exists? file)
+                   (report-formatting-issues package file line)
+                   (list (make-warning package
+                                       (G_ "source file not found"))))))))
         '())))
 
 \f