02/03: diagnostics, ui: Adjust to 'read-error' and 'syntax-error' in Guile 3.0.6.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 524c9800afb433cc474132185d8e37f72004adb3
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Thu Apr 29 00:38:03 2021 +0200

    diagnostics, ui: Adjust to 'read-error' and 'syntax-error' in Guile 3.0.6.
    
    * guix/diagnostics.scm (source-properties->location): Add clause for
    vectors.
    * guix/ui.scm (report-load-error): Tweak 'read-error' handling for 3.0.6.
    * tests/guix-package.sh: Relax regexp for the "unbound variable"
    diagnostic check.
    * tests/guix-system.sh: Adjust "missing closing paren" check for 3.0.6.
    * tests/records.scm (location-alist): New procedure.
    ("define-record-type* & wrong field specifier")
    ("define-record-type* & wrong field specifier, identifier")
    ("define-record-type* & duplicate initializers"): Use it.
---
 guix/diagnostics.scm  |  6 +++++-
 guix/ui.scm           | 10 ++++++----
 tests/guix-package.sh |  2 +-
 tests/guix-system.sh  |  8 +++++++-
 tests/records.scm     | 18 ++++++++++++++----
 5 files changed, 33 insertions(+), 11 deletions(-)

diff --git a/guix/diagnostics.scm b/guix/diagnostics.scm
index 7b9ffc6..6a792fe 100644
--- a/guix/diagnostics.scm
+++ b/guix/diagnostics.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic 
Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 
Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -233,6 +233,10 @@ etc."
           (make-location file (+ line 1) col)))
     (#f
      #f)
+    (#(file line column)
+     ;; Guile >= 3.0.6 uses vectors instead of alists internally, which can be
+     ;; seen in the arguments to 'syntax-error' exceptions.
+     (location file (+ 1 line) column))
     (_
      (let ((file (assq-ref loc 'filename))
            (line (assq-ref loc 'line))
diff --git a/guix/ui.scm b/guix/ui.scm
index 7fbd4c6..334dce2 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -376,12 +376,14 @@ ARGS is the list of arguments received by the 'throw' 
handler."
     (('system-error . rest)
      (let ((err (system-error-errno args)))
        (report-error (G_ "failed to load '~a': ~a~%") file (strerror err))))
-    (('read-error "scm_i_lreadparen" message _ ...)
+    (('read-error _ message args ...)
      ;; Guile's missing-paren messages are obscure so we make them more
      ;; intelligible here.
-     (if (string-suffix? "end of file" message)
-         (let ((location (string-drop-right message
-                                            (string-length "end of file"))))
+     (if (or (string-suffix? "end of file" message) ;Guile < 3.0.6
+             (and (string-contains message "unexpected end of input")
+                  (member '(#\)) args)))
+         (let ((location (string-take message
+                                      (+ 2 (string-contains message ": ")))))
            (format (current-error-port) (G_ "~amissing closing parenthesis~%")
                    location))
          (apply throw args)))
diff --git a/tests/guix-package.sh b/tests/guix-package.sh
index 39e2b51..92ab565 100644
--- a/tests/guix-package.sh
+++ b/tests/guix-package.sh
@@ -459,7 +459,7 @@ if guix package --bootstrap -n -m 
"$module_dir/manifest.scm" \
 then false
 else
     cat "$module_dir/stderr"
-    grep "manifest.scm:[1-3]:.*wonderful-package.*: unbound variable" \
+    grep "manifest.scm:[1-4]:.*wonderful-package.*: unbound variable" \
         "$module_dir/stderr"
 fi
 
diff --git a/tests/guix-system.sh b/tests/guix-system.sh
index 238c892..7e992e7 100644
--- a/tests/guix-system.sh
+++ b/tests/guix-system.sh
@@ -51,6 +51,7 @@ then
     # This must not succeed.
     exit 1
 else
+    cat "$errorfile"
     grep "$tmpfile:2:3:.*missing.* initializers" "$errorfile"
 fi
 
@@ -66,7 +67,12 @@ then
     # This must not succeed.
     exit 1
 else
-    grep "$tmpfile:4:1: missing closing paren" "$errorfile"
+    cat "$errorfile"
+
+    # Guile 3.0.6 gets line/column numbers for 'read-error' wrong
+    # (zero-indexed): <https://bugs.gnu.org/48089>.
+    grep "$tmpfile:4:1: missing closing paren" "$errorfile" || \
+    grep "$tmpfile:3:0: missing closing paren" "$errorfile"
 fi
 
 
diff --git a/tests/records.scm b/tests/records.scm
index 2c55a61..706bb3d 100644
--- a/tests/records.scm
+++ b/tests/records.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019, 2020 Ludovic Courtès 
<ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019, 2020, 2021 Ludovic 
Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -29,6 +29,16 @@
     (module-use! module (resolve-interface '(guix records)))
     module))
 
+(define (location-alist loc)
+  ;; Return a location alist.  In Guile < 3.0.6, LOC is always an alist, but
+  ;; starting with 3.0.6, LOC is a vector (at least when it comes from
+  ;; 'syntax-error' exceptions), hence this conversion.
+  (match loc
+    (#(file line column)
+     `((line . ,line) (column . ,column)
+       (filename . ,file)))
+    (_ loc)))
+
 
 (test-begin "records")
 
@@ -298,7 +308,7 @@
                     (pk 'expected-loc
                         `((line . ,(- (assq-ref loc 'line) 1))
                           ,@(alist-delete 'line loc)))
-                    (pk 'actual-loc location)))))))
+                    (pk 'actual-loc (location-alist location))))))))
 
 (test-assert "define-record-type* & wrong field specifier, identifier"
   (let ((exp '(begin
@@ -325,7 +335,7 @@
                     (pk 'expected-loc
                         `((line . ,(- (assq-ref loc 'line) 2))
                           ,@(alist-delete 'line loc)))
-                    (pk 'actual-loc location)))))))
+                    (pk 'actual-loc (location-alist location))))))))
 
 (test-assert "define-record-type* & missing initializers"
   (catch 'syntax-error
@@ -396,7 +406,7 @@
                     (pk 'expected-loc
                         `((line . ,(- (assq-ref loc 'line) 1))
                           ,@(alist-delete 'line loc)))
-                    (pk 'actual-loc location)))))))
+                    (pk 'actual-loc (location-alist location))))))))
 
 (test-assert "ABI checks"
   (let ((module (test-module)))