[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[bug#38754] [PATCH 3/4] lint: Add a #:store argument to check-derivation
From: |
Christopher Baines |
Subject: |
[bug#38754] [PATCH 3/4] lint: Add a #:store argument to check-derivation |
Date: |
Sun, 15 Mar 2020 21:06:30 +0000 |
This can then be used to avoid opening up a store connection each time a
package needs checking.
* guix/lint.scm (check-derivation): Add a #:store argument, and pull the
handling of the store connection out of the try function.
---
guix/lint.scm | 36 ++++++++++++++++++++----------------
1 file changed, 20 insertions(+), 16 deletions(-)
diff --git a/guix/lint.scm b/guix/lint.scm
index b20510b45d..cfe3be2302 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -917,9 +917,9 @@ descriptions maintained upstream."
(define exception-with-kind-and-args?
(const #f))))
-(define (check-derivation package)
+(define* (check-derivation package #:key store)
"Emit a warning if we fail to compile PACKAGE to a derivation."
- (define (try system)
+ (define (try store system)
(catch #t ;TODO: Remove 'catch' when Guile 2.x is no longer supported.
(lambda ()
(guard (c ((store-protocol-error? c)
@@ -938,25 +938,29 @@ descriptions maintained upstream."
(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))
- (package-derivation store package system #:graft? #f)
-
- ;; If there's a replacement, make sure we can compute its
- ;; derivation.
- (match (package-replacement package)
- (#f #t)
- (replacement
- (package-derivation store replacement system
- #:graft? #f)))))))
+ (parameterize ((%graft? #f))
+ (package-derivation store package system #:graft? #f)
+
+ ;; If there's a replacement, make sure we can compute its
+ ;; derivation.
+ (match (package-replacement package)
+ (#f #t)
+ (replacement
+ (package-derivation store replacement system
+ #:graft? #f))))))
(lambda args
(make-warning package
(G_ "failed to create ~a derivation: ~s")
(list system args)))))
- (filter lint-warning?
- (map try (package-supported-systems package))))
+ (define (check-with-store store)
+ (filter lint-warning?
+ (map (cut try store <>) (package-supported-systems package))))
+
+ ;; For backwards compatability, don't rely on store being set
+ (or (and=> store check-with-store)
+ (with-store store
+ (check-with-store store))))
(define (check-license package)
"Warn about type errors of the 'license' field of PACKAGE."
--
2.25.0