03/06: records: Improve reporting of "invalid field specifier" errors.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 47212fc763788660ff9051ccee1f6fa8a0db7bdd
Author: Ludovic Courtès <address@hidden>
AuthorDate: Thu Jan 16 15:00:18 2020 +0100

    records: Improve reporting of "invalid field specifier" errors.
    
    Previously users would just see:
    
      error: invalid field specifier
    
    without source location or hints.
    
    * guix/records.scm (expand): Add optional 'parent-form' parameter and
    pass it to 'syntax-violation' when it is true.
    (make-syntactic-constructor): Pass S as a third argument to
    'report-invalid-field-specifier'.
    * guix/ui.scm (report-load-error): For 'syntax-error', show SUBFORM or
    FORM in the message.
    * tests/records.scm ("define-record-type* & wrong field specifier"): Add
    a 'subform' parameter and adjust test accordingly.
    ("define-record-type* & wrong field specifier, identifier"): New test.
    * tests/guix-system.sh: Add test.
---
 guix/records.scm     | 19 ++++++++++++++-----
 guix/ui.scm          |  5 +++--
 tests/guix-system.sh | 22 +++++++++++++++++++++-
 tests/records.scm    | 34 +++++++++++++++++++++++++++++++---
 4 files changed, 69 insertions(+), 11 deletions(-)

diff --git a/guix/records.scm b/guix/records.scm
index 99507dc..4bda542 100644
--- a/guix/records.scm
+++ b/guix/records.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès 
<address@hidden>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic 
Courtès <address@hidden>
 ;;; Copyright © 2018 Mark H Weaver <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -70,14 +70,22 @@ interface\" (ABI) for TYPE is equal to COOKIE."
                  "~a: record ABI mismatch; recompilation needed"
                  (list #,type) '()))))
 
-  (define (report-invalid-field-specifier name bindings)
-    "Report the first invalid binding among BINDINGS."
+  (define* (report-invalid-field-specifier name bindings
+                                           #:optional parent-form)
+    "Report the first invalid binding among BINDINGS.  PARENT-FORM is used for
+error-reporting purposes."
     (let loop ((bindings bindings))
       (syntax-case bindings ()
         (((field value) rest ...)                   ;good
          (loop #'(rest ...)))
         ((weird _ ...)                              ;weird!
-         (syntax-violation name "invalid field specifier" #'weird)))))
+         ;; WEIRD may be an identifier, thus lacking source location info, and
+         ;; BINDINGS is a list, also lacking source location info.  Hopefully
+         ;; PARENT-FORM provides source location info.
+         (apply syntax-violation name "invalid field specifier"
+                (if parent-form
+                    (list parent-form #'weird)
+                    (list #'weird)))))))
 
   (define (report-duplicate-field-specifier name ctor)
     "Report the first duplicate identifier among the bindings in CTOR."
@@ -233,7 +241,8 @@ of TYPE matches the expansion-time ABI."
             ;; Report precisely which one is faulty, instead of letting the
             ;; "source expression failed to match any pattern" error.
             (report-invalid-field-specifier 'name
-                                            #'(bindings (... ...))))))))))
+                                            #'(bindings (... ...))
+                                            s))))))))
 
 (define-syntax-rule (define-field-property-predicate predicate property)
   "Define PREDICATE as a procedure that takes a syntax object and, when passed
diff --git a/guix/ui.scm b/guix/ui.scm
index b99a9e5..01aeee4 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -372,9 +372,10 @@ ARGS is the list of arguments received by the 'throw' 
handler."
            (format (current-error-port) (G_ "~amissing closing parenthesis~%")
                    location))
          (apply throw args)))
-    (('syntax-error proc message properties form . rest)
+    (('syntax-error proc message properties form subform . rest)
      (let ((loc (source-properties->location properties)))
-       (report-error loc (G_ "~a~%") message)))
+       (report-error loc (G_ "~s: ~a~%")
+                     (or subform form) message)))
     (('unbound-variable _ ...)
      (report-unbound-variable-error args #:frame frame))
     (((or 'srfi-34 '%exception) obj)
diff --git a/tests/guix-system.sh b/tests/guix-system.sh
index 1b2c425..271627c 100644
--- a/tests/guix-system.sh
+++ b/tests/guix-system.sh
@@ -1,5 +1,5 @@
 # GNU Guix --- Functional package management for GNU
-# Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès 
<address@hidden>
+# Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès 
<address@hidden>
 # Copyright © 2017 Tobias Geerinckx-Rice <address@hidden>
 # Copyright © 2018 Chris Marusich <address@hidden>
 #
@@ -130,6 +130,26 @@ else
     fi
 fi
 
+cat > "$tmpfile" <<EOF
+(use-modules (gnu))                                    ; 1
+
+(operating-system                                      ; 3
+  (file-systems (cons (file-system                     ; 4
+                        (device (file-system-label "root"))
+                        (mount-point "/")              ; 6
+                        (type "ext4"))))               ; 7 (!!)
+                      %base-file-systems)
+EOF
+
+if guix system build "$tmpfile" -n 2> "$errorfile"
+then false
+else
+    # Here '%base-file-systems' appears as if it were a field specified of the
+    # enclosing 'operating-system' form due to parenthesis mismatch.
+    grep "$tmpfile:3:[0-9]\+:.*%base-file-system.*invalid field specifier" \
+        "$errorfile"
+fi
+
 OS_BASE='
   (host-name "antelope")
   (timezone "Europe/Paris")
diff --git a/tests/records.scm b/tests/records.scm
index 16b7a9c..2c55a61 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 Ludovic Courtès 
<address@hidden>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019, 2020 Ludovic Courtès 
<address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -286,10 +286,11 @@
       (lambda ()
         (eval exp (test-module))
         #f)
-      (lambda (key proc message location form . args)
+      (lambda (key proc message location form subform . _)
         (and (eq? proc 'foo)
              (string-match "invalid field" message)
-             (equal? form '(baz 1 2 3 4 5))
+             (equal? subform '(baz 1 2 3 4 5))
+             (equal? form '(foo (baz 1 2 3 4 5)))
 
              ;; Make sure the location is that of the field specifier.
              ;; See <http://bugs.gnu.org/23969>.
@@ -299,6 +300,33 @@
                           ,@(alist-delete 'line loc)))
                     (pk 'actual-loc location)))))))
 
+(test-assert "define-record-type* & wrong field specifier, identifier"
+  (let ((exp '(begin
+                (define-record-type* <foo> foo make-foo
+                  foo?
+                  (bar foo-bar (default 42))
+                  (baz foo-baz))
+
+                (foo
+                 baz)))                           ;syntax error
+        (loc    (current-source-location)))       ;keep this alignment!
+    (catch 'syntax-error
+      (lambda ()
+        (eval exp (test-module))
+        #f)
+      (lambda (key proc message location form subform . _)
+        (and (eq? proc 'foo)
+             (string-match "invalid field" message)
+             (equal? subform 'baz)
+             (equal? form '(foo baz))
+
+             ;; Here the location is that of the parent form.
+             (lset= equal?
+                    (pk 'expected-loc
+                        `((line . ,(- (assq-ref loc 'line) 2))
+                          ,@(alist-delete 'line loc)))
+                    (pk 'actual-loc location)))))))
+
 (test-assert "define-record-type* & missing initializers"
   (catch 'syntax-error
     (lambda ()