me
/
guix
Archived
1
0
Fork 0
Code

ui, lint: Simplify exception handling in Guile 3 style. 

* guix/lint.scm (check-derivation)[try]: Remove "catch #t" wrapping.
* guix/ui.scm (call-with-error-handling): Remove "catch 'system-error"
and move 'system-error handling to the &exception-with-kind-and-args
clause.
master
Ludovic Courtès 2021-05-26 23:06:13 +02:00
parent 82d8ab01f5
commit 5bcb4f8a58
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 39 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

70
guix/lint.scm
View File

@ -1010,45 +1010,39 @@ descriptions maintained upstream."
(define* (check-derivation package #:key store) (define* (check-derivation package #:key store)
"Emit a warning if we fail to compile PACKAGE to a derivation." "Emit a warning if we fail to compile PACKAGE to a derivation."
(define (try store system) (define (try store system)
(catch #t ;TODO: Remove 'catch' when Guile 2.x is no longer supported. (guard (c ((store-protocol-error? c)
(lambda () (make-warning package
(guard (c ((store-protocol-error? c) (G_ "failed to create ~a derivation: ~a")
(make-warning package (list system
(G_ "failed to create ~a derivation: ~a") (store-protocol-error-message c))))
(list system ((exception-with-kind-and-args? c)
(store-protocol-error-message c)))) (make-warning package
((exception-with-kind-and-args? c) (G_ "failed to create ~a derivation: ~s")
(make-warning package (list system
(G_ "failed to create ~a derivation: ~s") (cons (exception-kind c)
(list system (exception-args c)))))
(cons (exception-kind c) ((message-condition? c)
(exception-args c))))) (make-warning package
((message-condition? c) (G_ "failed to create ~a derivation: ~a")
(make-warning package (list system
(G_ "failed to create ~a derivation: ~a") (condition-message c))))
(list system ((formatted-message? c)
(condition-message c)))) (let ((str (apply format #f
((formatted-message? c) (formatted-message-string c)
(let ((str (apply format #f (formatted-message-arguments c))))
(formatted-message-string c) (make-warning package
(formatted-message-arguments c)))) (G_ "failed to create ~a derivation: ~a")
(make-warning package (list system str)))))
(G_ "failed to create ~a derivation: ~a") (parameterize ((%graft? #f))
(list system str))))) (package-derivation store package system #:graft? #f)
(parameterize ((%graft? #f))
(package-derivation store package system #:graft? #f)
;; If there's a replacement, make sure we can compute its ;; If there's a replacement, make sure we can compute its
;; derivation. ;; derivation.
(match (package-replacement package) (match (package-replacement package)
(#f #t) (#f #t)
(replacement (replacement
(package-derivation store replacement system (package-derivation store replacement system
#:graft? #f)))))) #:graft? #f))))))
(lambda args
(make-warning package
(G_ "failed to create ~a derivation: ~s")
(list system args)))))
(define (check-with-store store) (define (check-with-store store)
(filter lint-warning? (filter lint-warning?

14
guix/ui.scm
View File

@ -812,7 +812,12 @@ directories:~{ ~a~}~%")
;; been unwound when we re-raise, since that would otherwise show ;; been unwound when we re-raise, since that would otherwise show
;; useless backtraces. ;; useless backtraces.
(((exception-predicate &exception-with-kind-and-args) c) (((exception-predicate &exception-with-kind-and-args) c)
(raise c)) (if (eq? 'system-error (exception-kind c)) ;EPIPE & co.
(match (exception-args c)
((proc format-string format-args . _)
(leave (G_ "~a: ~a~%") proc
(apply format #f format-string format-args))))
(raise c)))
((message-condition? c) ((message-condition? c)
;; Normally '&message' error conditions have an i18n'd message. ;; Normally '&message' error conditions have an i18n'd message.
@ -822,12 +827,7 @@ directories:~{ ~a~}~%")
(when (fix-hint? c) (when (fix-hint? c)
(display-hint (condition-fix-hint c))) (display-hint (condition-fix-hint c)))
(exit 1))) (exit 1)))
;; Catch EPIPE and the likes. (thunk)))
(catch 'system-error
thunk
(lambda (key proc format-string format-args . rest)
(leave (G_ "~a: ~a~%") proc
(apply format #f format-string format-args))))))
(define-syntax-rule (leave-on-EPIPE exp ...) (define-syntax-rule (leave-on-EPIPE exp ...)
"Run EXP... in a context where EPIPE errors are caught and lead to 'exit' "Run EXP... in a context where EPIPE errors are caught and lead to 'exit'