From: Ludovic Courtès <ludo@gnu.org>
Date: Wed, 26 May 2021 21:06:13 +0000 (+0200)
Subject: ui, lint: Simplify exception handling in Guile 3 style.
X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/commitdiff_plain/5bcb4f8a58ad316174768c167927c03be3272786

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.
---

diff --git a/guix/lint.scm b/guix/lint.scm
index 023a179ea6..41dd5d0633 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -1010,45 +1010,39 @@ descriptions maintained upstream."
 (define* (check-derivation package #:key store)
   "Emit a warning if we fail to compile PACKAGE to a derivation."
   (define (try store system)
-    (catch #t     ;TODO: Remove 'catch' when Guile 2.x is no longer supported.
-      (lambda ()
-        (guard (c ((store-protocol-error? c)
-                   (make-warning package
-                                 (G_ "failed to create ~a derivation: ~a")
-                                 (list system
-                                       (store-protocol-error-message c))))
-                  ((exception-with-kind-and-args? c)
-                   (make-warning package
-                                 (G_ "failed to create ~a derivation: ~s")
-                                 (list system
-                                       (cons (exception-kind c)
-                                             (exception-args c)))))
-                  ((message-condition? c)
-                   (make-warning package
-                                 (G_ "failed to create ~a derivation: ~a")
-                                 (list system
-                                       (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)
-
-            ;; 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)))))
+    (guard (c ((store-protocol-error? c)
+               (make-warning package
+                             (G_ "failed to create ~a derivation: ~a")
+                             (list system
+                                   (store-protocol-error-message c))))
+              ((exception-with-kind-and-args? c)
+               (make-warning package
+                             (G_ "failed to create ~a derivation: ~s")
+                             (list system
+                                   (cons (exception-kind c)
+                                         (exception-args c)))))
+              ((message-condition? c)
+               (make-warning package
+                             (G_ "failed to create ~a derivation: ~a")
+                             (list system
+                                   (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)
+
+        ;; 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))))))
 
   (define (check-with-store store)
     (filter lint-warning?
diff --git a/guix/ui.scm b/guix/ui.scm
index 6b0155f563..d3e01f846d 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -812,7 +812,12 @@ directories:~{ ~a~}~%")
              ;; been unwound when we re-raise, since that would otherwise show
              ;; useless backtraces.
              (((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)
               ;; Normally '&message' error conditions have an i18n'd message.
@@ -822,12 +827,7 @@ directories:~{ ~a~}~%")
               (when (fix-hint? c)
                 (display-hint (condition-fix-hint c)))
               (exit 1)))
-      ;; Catch EPIPE and the likes.
-      (catch 'system-error
-        thunk
-        (lambda (key proc format-string format-args . rest)
-          (leave (G_ "~a: ~a~%") proc
-                 (apply format #f format-string format-args))))))
+      (thunk)))
 
 (define-syntax-rule (leave-on-EPIPE exp ...)
   "Run EXP... in a context where EPIPE errors are caught and lead to 'exit'