[bug#52724] [PATCH] guix: Prepare the UI for continuable &warning exceptions.

[bug#52724] [PATCH] guix: Prepare the UI for continuable &warning exceptions.

[Attila Lendvai]

* guix/store.scm (call-with-store): Use raise-continuable to resignal
exceptions.  This is needed for a later commit that uses continuable
exceptions from within git-authenticate to signal warnings that are meant to
be displayed for the user.  The reason for this is that this way unit tests
can explicitly check with a handler that a warning was indeed signalled.
* guix/ui.scm (call-with-error-handling): Handle &warning type exceptions by
printing them to the user, and then continuing at the place where they were
signalled at.
* guix/diagnostics.scm (emit-formatted-warning): New exported
function.
---

this is used in an upcoming patch, filed under a separate id.

 guix/diagnostics.scm |  4 ++++
 guix/store.scm       |  7 +++++--
 guix/ui.scm          | 11 ++++++++++-
 3 files changed, 19 insertions(+), 3 deletions(-)

diff --git a/guix/diagnostics.scm b/guix/diagnostics.scm
index 337a73c1a2..8e13e5e30a 100644
--- a/guix/diagnostics.scm
+++ b/guix/diagnostics.scm
@@ -48,6 +48,7 @@ (define-module (guix diagnostics)
             formatted-message?
             formatted-message-string
             formatted-message-arguments
+            emit-formatted-warning
 
             &fix-hint
             fix-hint?
@@ -163,6 +164,9 @@ (define-syntax-rule (leave args ...)
     (report-error args ...)
     (exit 1)))
 
+(define* (emit-formatted-warning fmt . args)
+  (emit-diagnostic fmt args #:prefix (G_ "warning: ") #:colors %warning-color))
+
 (define* (emit-diagnostic fmt args
                           #:key location (colors (color)) (prefix ""))
   "Report diagnostic message FMT with the given ARGS and the specified
diff --git a/guix/store.scm b/guix/store.scm
index a93e9596d9..a2b3b2f05a 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -34,6 +34,8 @@ (define-module (guix store)
   #:use-module (guix profiling)
   #:autoload   (guix build syscalls) (terminal-columns)
   #:use-module (rnrs bytevectors)
+  #:use-module ((rnrs conditions) #:select (warning?))
+  #:use-module ((rnrs exceptions) #:select (raise-continuable))
   #:use-module (ice-9 binary-ports)
   #:use-module ((ice-9 control) #:select (let/ec))
   #:use-module (ice-9 atomic)
@@ -661,8 +663,9 @@ (define (thunk)
             (apply values results)))))
 
     (with-exception-handler (lambda (exception)
-                              (close-connection store)
-                              (raise-exception exception))
+                              (unless (warning? exception)
+                                (close-connection store))
+                              (raise-continuable exception))
       thunk)))
 
 (define-syntax-rule (with-store store exp ...)
diff --git a/guix/ui.scm b/guix/ui.scm
index bd999103ff..f492b838d2 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -69,6 +69,8 @@ (define-module (guix ui)
   #:use-module (srfi srfi-31)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
+  #:use-module ((rnrs conditions)
+                #:select (warning?))
   #:autoload   (ice-9 ftw)  (scandir)
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
@@ -690,7 +692,14 @@ (define (port-filename* port)
     (and (not (port-closed? port))
          (port-filename port)))
 
-  (guard* (c ((package-input-error? c)
+  (guard* (c ((warning? c)
+              (if (formatted-message? c)
+                  (apply emit-formatted-warning
+                         (formatted-message-string c)
+                         (formatted-message-arguments c))
+                  (emit-formatted-warning "~a" c))
+              '())
+             ((package-input-error? c)
               (let* ((package  (package-error-package c))
                      (input    (package-error-invalid-input c))
                      (location (package-location package))
-- 
2.34.0

[bug#52724] [PATCH] guix: Prepare the UI for continuable &warning exceptions.

[Maxime Devos]

Hi,

>+  (guard* (c ((warning? c)
>+              (if (formatted-message? c)
>+                  (apply emit-formatted-warning
>+                         (formatted-message-string c)
>+                         (formatted-message-arguments c))
>+                  (emit-formatted-warning "~a" c))
>+              '())

I think this is better placed right before the 'formatted-message?',
instead of before the 'package-input-error?'. Or maybe inside the
'formatted-message?' clause? If you put it inside the
'formatted-message?' clause, you would get fix hint support for free.

I don't think the empty list as return value is meaningful here,
maybe return nothing at all instead (using (values))?

Also, you can't meaningfully stringify a condition.
E.g.,

(display (condition (make-warning) (make-who-condition 'foo)))
#<&compound-exception components: (#<&warning> #<&origin origin: foo>)>

I don't think "warning: #<& foo:(#<&bar &baz> ...)...>" messages are
very useful, so I would simply not handle warning? conditions that
aren't formatted-message?.

E.g.,:
  (guard* (c [...]
             ((and (warning? c) (formatted-message? c))
              do-things)
             [...])
    [...])

The downside is that, whenever some code raises a &warning that isn't
also a &formatted-message, (guix ui) needs to be adjusted to support it
as well, but that's acceptable I think.

Also, a test or two would be great (unfortunately call-with-error-
handling appears to be untested ...).

Greetings,
Maxime.

[bug#52724] [PATCH v2] guix: Prepare the UI for continuable &warning exceptions.

[Attila Lendvai]

* guix/store.scm (call-with-store): Use RAISE-CONTINUABLE to resignal
exceptions.  This is needed for a later commit that uses continuable
exceptions from within GIT-AUTHENTICATE to signal warnings that are meant to
be displayed to the user.  The reason for this is that this way unit tests
can use a handler to explicitly check that a warning was indeed signalled.
* guix/ui.scm (call-with-error-handling): Handle &WARNING type exceptions by
printing them to the user, and then continuing at the place where they were
signalled at.
(maybe-display-fix-hint): New procedure.
* guix/diagnostics.scm (emit-formatted-warning): New procedure. Exported.
---

thanks for the feedback! i've applied everything you pointed out.

i didn't merge it with the formatted-message? entry, because i'd
like a place where every warning ends up. instead, i have factored
out a maybe-display-fix-hint function, and used it there, too.

> Also, you can't meaningfully stringify a condition.

in case of warnings, you're right. i just have a knee-jerk reaction
against silently swallowing errors, and it kicked in here, too.

> Also, a test or two would be great

i don't really know how to write a test for this.

the way i was testing it is that a future commit will add a warning
when the channel intro commit doesn't set up .guix-authorizations properly,
and i had set up a branch from which i tried to pull.

 guix/diagnostics.scm |  4 ++++
 guix/store.scm       |  7 +++++--
 guix/ui.scm          | 30 ++++++++++++++++++++++++------
 3 files changed, 33 insertions(+), 8 deletions(-)

diff --git a/guix/diagnostics.scm b/guix/diagnostics.scm
index 337a73c1a2..8e13e5e30a 100644
--- a/guix/diagnostics.scm
+++ b/guix/diagnostics.scm
@@ -48,6 +48,7 @@ (define-module (guix diagnostics)
             formatted-message?
             formatted-message-string
             formatted-message-arguments
+            emit-formatted-warning
 
             &fix-hint
             fix-hint?
@@ -163,6 +164,9 @@ (define-syntax-rule (leave args ...)
     (report-error args ...)
     (exit 1)))
 
+(define* (emit-formatted-warning fmt . args)
+  (emit-diagnostic fmt args #:prefix (G_ "warning: ") #:colors %warning-color))
+
 (define* (emit-diagnostic fmt args
                           #:key location (colors (color)) (prefix ""))
   "Report diagnostic message FMT with the given ARGS and the specified
diff --git a/guix/store.scm b/guix/store.scm
index a93e9596d9..a2b3b2f05a 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -34,6 +34,8 @@ (define-module (guix store)
   #:use-module (guix profiling)
   #:autoload   (guix build syscalls) (terminal-columns)
   #:use-module (rnrs bytevectors)
+  #:use-module ((rnrs conditions) #:select (warning?))
+  #:use-module ((rnrs exceptions) #:select (raise-continuable))
   #:use-module (ice-9 binary-ports)
   #:use-module ((ice-9 control) #:select (let/ec))
   #:use-module (ice-9 atomic)
@@ -661,8 +663,9 @@ (define (thunk)
             (apply values results)))))
 
     (with-exception-handler (lambda (exception)
-                              (close-connection store)
-                              (raise-exception exception))
+                              (unless (warning? exception)
+                                (close-connection store))
+                              (raise-continuable exception))
       thunk)))
 
 (define-syntax-rule (with-store store exp ...)
diff --git a/guix/ui.scm b/guix/ui.scm
index bd999103ff..96f9db722c 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -69,6 +69,8 @@ (define-module (guix ui)
   #:use-module (srfi srfi-31)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
+  #:use-module ((rnrs conditions)
+                #:select (warning?))
   #:autoload   (ice-9 ftw)  (scandir)
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
@@ -299,6 +301,11 @@ (define (module<? m1 m2)
 
 (define %hint-color (color BOLD CYAN))
 
+(define (maybe-display-fix-hint obj)
+  (when (fix-hint? obj)
+    (display-hint (condition-fix-hint obj)))
+  obj)
+
 (define* (display-hint message #:optional (port (current-error-port)))
   "Display MESSAGE, a l10n message possibly containing Texinfo markup, to
 PORT."
@@ -398,8 +405,7 @@ (define* (report-load-error file args #:optional frame)
                    (formatted-message-arguments obj)))
            (else
             (report-error (G_ "exception thrown: ~s~%") obj)))
-     (when (fix-hint? obj)
-       (display-hint (condition-fix-hint obj))))
+     (maybe-display-fix-hint obj))
     ((key args ...)
      (report-error (G_ "failed to load '~a':~%") file)
      (match args
@@ -796,13 +802,26 @@ (define (manifest-entry-output* entry)
                      (cons (invoke-error-program c)
                            (invoke-error-arguments c))))
 
+             ((warning? c)
+              (match c
+                ((? formatted-message? c)
+                 (apply emit-formatted-warning
+                        (formatted-message-string c)
+                        (formatted-message-arguments c)))
+                (_
+                 ;; Ignore warnings that we cannot display in a meaningful way
+                 ;; to the user.  As a developer, you may peek using:
+                 ;; (emit-formatted-warning "~a" c)
+                 (values)))
+              (maybe-display-fix-hint c)
+              (values))
+
              ((formatted-message? c)
               (apply report-error
                      (and (error-location? c) (error-location c))
                      (gettext (formatted-message-string c) %gettext-domain)
                      (formatted-message-arguments c))
-              (when (fix-hint? c)
-                (display-hint (condition-fix-hint c)))
+              (maybe-display-fix-hint c)
               (exit 1))
 
              ;; On Guile 3.0.0, exceptions such as 'unbound-variable' are
@@ -826,8 +845,7 @@ (define (manifest-entry-output* entry)
               (report-error (and (error-location? c) (error-location c))
                             (G_ "~a~%")
                             (gettext (condition-message c) %gettext-domain))
-              (when (fix-hint? c)
-                (display-hint (condition-fix-hint c)))
+              (maybe-display-fix-hint c)
               (exit 1)))
       (thunk)))
 
-- 
2.34.0