From babc2c80a7e1f1b5e72fd1685ef6604b93157a8e Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Thu, 14 Jul 2016 18:58:36 +0200
Subject: [PATCH] records: Improve reporting of invalid field specifiers.

Fixes <http://bugs.gnu.org/23969>.
Reported by Vincent Legoll <vincent.legoll@gmail.com>.

* guix/records.scm (report-invalid-field-specifier): New procedure.
* tests/records.scm ("define-record-type* & wrong field specifier"): New
test.
---
 guix/records.scm  | 19 +++++++++++++++++--
 tests/records.scm | 29 ++++++++++++++++++++++++++++-
 2 files changed, 45 insertions(+), 3 deletions(-)

diff --git a/guix/records.scm b/guix/records.scm
index 0d35a747b0..f3f3aafb04 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 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -42,6 +42,15 @@
                        (format #f fmt args ...)
                        form))))
 
+(define (report-invalid-field-specifier name bindings)
+  "Report the first invalid binding among BINDINGS."
+  (let loop ((bindings bindings))
+    (syntax-case bindings ()
+      (((field value) rest ...)                   ;good
+       (loop #'(rest ...)))
+      ((weird _ ...)                              ;weird!
+       (syntax-violation name "invalid field specifier" #'weird)))))
+
 (define-syntax make-syntactic-constructor
   (syntax-rules ()
     "Make the syntactic constructor NAME for TYPE, that calls CTOR, and
@@ -147,7 +156,13 @@ fields, and DELAYED is the list of identifiers of delayed fields."
                                      "missing field initializers ~a"
                                      (lset-difference eq?
                                                       '(expected ...)
-                                                      fields)))))))))))))
+                                                      fields)))))))
+           ((_ bindings (... ...))
+            ;; One of BINDINGS doesn't match the (field value) pattern.
+            ;; Report precisely which one is faulty, instead of letting the
+            ;; "source expression failed to match any pattern" error.
+            (report-invalid-field-specifier 'name
+                                            #'(bindings (... ...))))))))))
 
 (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/tests/records.scm b/tests/records.scm
index c6f85d4a81..d6d27bb96a 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 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -17,6 +17,7 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (test-records)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-64)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
@@ -214,6 +215,32 @@
              (equal? (foo-bar y) 1))              ;promise was already forced
            (eq? (foo-baz y) 'b)))))
 
+(test-assert "define-record-type* & wrong field specifier"
+  (let ((exp '(begin
+                (define-record-type* <foo> foo make-foo
+                  foo?
+                  (bar foo-bar (default 42))
+                  (baz foo-baz))
+
+                (foo (baz 1 2 3 4 5))))           ;syntax error
+        (loc         (current-source-location)))  ;keep this alignment!
+    (catch 'syntax-error
+      (lambda ()
+        (eval exp (test-module))
+        #f)
+      (lambda (key proc message location form . args)
+        (and (eq? proc 'foo)
+             (string-match "invalid field" message)
+             (equal? form '(baz 1 2 3 4 5))
+
+             ;; Make sure the location is that of the field specifier.
+             ;; See <http://bugs.gnu.org/23969>.
+             (lset= equal?
+                    (pk 'expected-loc
+                        `((line . ,(- (assq-ref loc 'line) 1))
+                          ,@(alist-delete 'line loc)))
+                    (pk 'actual-loc location)))))))
+
 (test-assert "define-record-type* & missing initializers"
   (catch 'syntax-error
     (lambda ()