records: Warn about shadowing due to inherited field value bindings.

This is a followup to a7c8e68dc51144a6d3981b770aca9c4897fc7c0c: this commit
introduced a new binding in the body of field values, which could silently
shadow outer bindings.  This new warning catches potentially unwanted
shadowing.

* guix/records.scm (make-syntactic-constructor)[check-shadowing]: New
procedure.
[wrap-field-value]: Use it.
* tests/records.scm ("define-record-type* & inherited value shadowing"): New
test.

Change-Id: I81ad14cf10da7213e9f8db987c8b0bd4c41acba2
Signed-off-by: Ludovic Courtès <ludo@gnu.org>
Merges: #7424

2 files changed, 39 insertions, 0 deletions

diff --git a/guix/records.scm b/guix/records.scm
index bf746d3b5d9..52d03f73942 100644
--- a/guix/records.scm
+++ b/guix/records.scm
@@ -24,6 +24,7 @@
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
   #:use-module (ice-9 rdelim)
+  #:autoload   (system syntax) (syntax-local-binding)
   #:export (define-record-type*
             this-record
 
@@ -206,6 +207,23 @@ of TYPE matches the expansion-time ABI."
                       index
                       (loop rest (+ 1 index))))))))
 
+         (define (check-shadowing identifier)
+           ;; Warn if IDENTIFIER shadows a local binding.
+           ;; Note: not using (guix diagnostics) to remain independent of
+           ;; other Guix modules.
+           (when (eq? 'lexical (syntax-local-binding identifier))
+             (format (current-warning-port)
+                     "~a: inherited field binding '~a' of \
+record type '~a' shadows local variable~%"
+                     (match (syntax-source identifier)
+                       (#f "<unknown-location>")
+                       (lst (format #f "~a:~a:~a"
+                                    (assq-ref lst 'filename)
+                                    (and=> (assq-ref lst 'line) 1+)
+                                    (assq-ref lst 'column))))
+                     (syntax->datum identifier)
+                     (syntax->datum #'type))))
+
          (define* (wrap-field-value f value #:optional parent)
            ;; Wrap VALUE, the value of field F, such that its sanitizer is
            ;; called and its properties (thunked, delayed) honored.  When
@@ -222,6 +240,7 @@ of TYPE matches the expansion-time ABI."
                                        #`((struct-ref #,parent
                                                       #,(field-index f))
                                           #,this-identifier)))
+                          (check-shadowing f)
                           #`(lambda (x)
                               (syntax-parameterize ((#,this-identifier
                                                      (lambda (s)
diff --git a/tests/records.scm b/tests/records.scm
index 9c071334d50..57a21d2effc 100644
--- a/tests/records.scm
+++ b/tests/records.scm
@@ -302,6 +302,26 @@
         =>
         (,(foo-bar child) ,(foo-baz child))))))
 
+(test-assert "define-record-type* & inherited value shadowing"
+  (let ((exp '(begin
+                (define-record-type* <foo> foo make-foo
+                  foo?
+                  (bar foo-bar)
+                  (baz foo-baz (thunked)))
+
+                (let ((x (foo (bar 1) (baz 2)))
+                      (baz 123))
+                  ;; Below, the 'baz' binding for the inherited field value
+                  ;; shadows the 'baz' above, which should trigger a warning.
+                  (foo (inherit x)
+                       (baz (* baz 2)))))))
+    (string-contains
+     (call-with-output-string
+       (lambda (port)
+         (parameterize ((current-warning-port port))
+           (eval exp (test-module)))))
+     "shadows local variable")))
+
 (test-assert "define-record-type* & delayed"
   (begin
     (define-record-type* <foo> foo make-foo