aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMaxime Devos <maximedevos@telenet.be>2021-07-01 12:51:14 +0200
committerMathieu Othacehe <othacehe@gnu.org>2021-07-07 10:00:52 +0200
commita8e4c158f9b7cc0adf010313b0f974e1a1aa63a7 (patch)
treecdb12da5af67dd64bc51a01e967263f6c14d0e90
parent8333673c4c33d269139ded0d9f67d99f6369f736 (diff)
downloadguix-a8e4c158f9b7cc0adf010313b0f974e1a1aa63a7.tar
guix-a8e4c158f9b7cc0adf010313b0f974e1a1aa63a7.tar.gz
lint: Define some procedures for analysing code in phases.
* guix/lint.scm (check-optional-tests): Extract logic for extracting the phases from a package to ... (find-phase-deltas): ... here, and ... (report-bogus-phase-deltas): ... here. (check-optional-tests)[check-check-procedure]: Extract code for extracting the procedure body to ... (find-procedure-body) ... here. (find-phase-procedure): New procedure. (report-bogus-phase-procedure): New procedure. Signed-off-by: Mathieu Othacehe <othacehe@gnu.org>
-rw-r--r--guix/lint.scm117
1 files changed, 84 insertions, 33 deletions
diff --git a/guix/lint.scm b/guix/lint.scm
index 1f48bcc454..5125b7722c 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -163,6 +163,78 @@
;;;
+;;; Procedures for analysing Scheme code in package definitions
+;;;
+
+(define* (find-procedure-body expression found
+ #:key (not-found (const '())))
+ "Try to find the body of the procedure defined inline by EXPRESSION.
+If it was found, call FOUND with its body. If it wasn't, call
+the thunk NOT-FOUND."
+ (match expression
+ (`(,(or 'let 'let*) . ,_)
+ (find-procedure-body (car (last-pair expression)) found
+ #:not-found not-found))
+ (`(,(or 'lambda 'lambda*) ,_ . ,code)
+ (found code))
+ (_ (not-found))))
+
+(define* (report-bogus-phase-deltas package bogus-deltas)
+ "Report a bogus invocation of ‘modify-phases’."
+ (list (make-warning package
+ ;; TRANSLATORS: 'modify-phases' is a Scheme syntax
+ ;; and should not be translated.
+ (G_ "incorrect call to ‘modify-phases’")
+ #:field 'arguments)))
+
+(define* (find-phase-deltas package found
+ #:key (not-found (const '()))
+ (bogus
+ (cut report-bogus-phase-deltas package <>)))
+ "Try to find the clauses of the ‘modify-phases’ form in the phases
+specification of PACKAGE. If they were found, all FOUND with a list
+of the clauses. If they weren't (e.g. because ‘modify-phases’ wasn't
+used at all), call the thunk NOT-FOUND instead. If ‘modify-phases’
+was used, but the clauses don't form a list, call BOGUS with the
+not-a-list."
+ (apply (lambda* (#:key phases #:allow-other-keys)
+ (define phases/sexp
+ (if (gexp? phases)
+ (gexp->approximate-sexp phases)
+ phases))
+ (match phases/sexp
+ (`(modify-phases ,_ . ,changes)
+ ((if (list? changes) found bogus) changes))
+ (_ (not-found))))
+ (package-arguments package)))
+
+(define (report-bogus-phase-procedure package)
+ "Report a syntactically-invalid phase clause."
+ (list (make-warning package
+ ;; TRANSLATORS: See ‘modify-phases’ in the manual.
+ (G_ "invalid phase clause")
+ #:field 'arguments)))
+
+(define* (find-phase-procedure package expression found
+ #:key (not-found (const '()))
+ (bogus (cut report-bogus-phase-procedure
+ package)))
+ "Try to find the procedure in the phase clause EXPRESSION. If it was
+found, call FOUND with the procedure expression. If EXPRESSION isn't
+actually a phase clause, call the thunk BOGUS. If the phase form doesn't
+have a procedure, call the thunk NOT-FOUND."
+ (match expression
+ (('add-after before after proc-expr)
+ (found proc-expr))
+ (('add-before after before proc-expr)
+ (found proc-expr))
+ (('replace _ proc-expr)
+ (found proc-expr))
+ (('delete _) (not-found))
+ (_ (bogus))))
+
+
+;;;
;;; Checkers
;;;
@@ -1111,46 +1183,25 @@ descriptions maintained upstream."
(define (sexp-uses-tests?? sexp)
"Test if SEXP contains the symbol 'tests?'."
(sexp-contains-atom? sexp 'tests?))
+ (define (check-procedure-body code)
+ (if (sexp-uses-tests?? code)
+ '()
+ (list (make-warning package
+ ;; TRANSLATORS: check and #:tests? are a
+ ;; Scheme symbol and keyword respectively
+ ;; and should not be translated.
+ (G_ "the 'check' phase should respect #:tests?")
+ #:field 'arguments))))
(define (check-check-procedure expression)
- (match expression
- (`(,(or 'let 'let*) . ,_)
- (check-check-procedure (car (last-pair expression))))
- (`(,(or 'lambda 'lambda*) ,_ . ,code)
- (if (sexp-uses-tests?? code)
- '()
- (list (make-warning package
- ;; TRANSLATORS: check and #:tests? are a
- ;; Scheme symbol and keyword respectively
- ;; and should not be translated.
- (G_ "the 'check' phase should respect #:tests?")
- #:field 'arguments))))
- (_ '())))
+ (find-procedure-body expression check-procedure-body))
(define (check-phases-delta delta)
(match delta
(`(replace 'check ,expression)
(check-check-procedure expression))
(_ '())))
(define (check-phases-deltas deltas)
- (match deltas
- (() '())
- ((head . tail)
- (append (check-phases-delta head)
- (check-phases-deltas tail)))
- (_ (list (make-warning package
- ;; TRANSLATORS: modify-phases is a Scheme
- ;; syntax and must not be translated.
- (G_ "incorrect call to ‘modify-phases’")
- #:field 'arguments)))))
- (apply (lambda* (#:key phases #:allow-other-keys)
- (define phases/sexp
- (if (gexp? phases)
- (gexp->approximate-sexp phases)
- phases))
- (match phases/sexp
- (`(modify-phases ,_ . ,changes)
- (check-phases-deltas changes))
- (_ '())))
- (package-arguments package)))
+ (append-map check-phases-delta deltas))
+ (find-phase-deltas package check-phases-deltas))
(define* (check-derivation package #:key store)
"Emit a warning if we fail to compile PACKAGE to a derivation."