From 45e26da1e4c8559b843034de3fd2edef89f5349c Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Thu, 19 Apr 2018 12:33:25 -0400
Subject: [PATCH 3/3] DRAFT: records: Detect duplicate field initializers.

---
 guix/records.scm | 33 +++++++++++++++++++++++++++------
 1 file changed, 27 insertions(+), 6 deletions(-)

diff --git a/guix/records.scm b/guix/records.scm
index c02395f2a..d6f97b288 100644
--- a/guix/records.scm
+++ b/guix/records.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018 Mark H Weaver <mhw@netris.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -74,9 +75,13 @@ fields, and DELAYED is the list of identifiers of delayed fields."
                           field+value)
                     car))
 
-           ;; Make sure there are no unknown field names.
+           ;; Make sure there are no duplicates, and no unknown field names.
            (let* ((fields     (map (compose car syntax->datum) field+value))
+                  (duplicates (find-duplicates fields))
                   (unexpected (lset-difference eq? fields '(expected ...))))
+             (when (pair? duplicates)
+               (record-error 'name s "duplicate field initializers ~a"
+                             duplicates))
              (when (pair? unexpected)
                (record-error 'name s "extraneous field initializers ~a"
                              unexpected)))
@@ -127,23 +132,39 @@ fields, and DELAYED is the list of identifiers of delayed fields."
                         #,(wrap-field-value #'field #'value)))))
                 field+value))
 
+         (define (find-duplicates lst)
+           ;; Return all elements of LST that occur more than once.
+           ;; Elements are compared using 'eq?'.
+           (match lst
+             ((x . rest)
+              (if (memq x rest)
+                  (lset-adjoin eq? (find-duplicates rest) x)
+                  (find-duplicates rest)))
+             (()
+              '())))
+
          (syntax-case s (inherit expected ...)
            ((_ (inherit orig-record) (field value) (... ...))
             #`(let* #,(field-bindings #'((field value) (... ...)))
                 #,(record-inheritance #'orig-record
                                       #'((field value) (... ...)))))
            ((_ (field value) (... ...))
-            (let ((fields (map syntax->datum #'(field (... ...)))))
+            (let ()
               (define (field-value f)
                 (or (find (lambda (x)
                             (eq? f (syntax->datum x)))
                           #'(field (... ...)))
                     (wrap-field-value f (field-default-value f))))
 
-              (let ((fields (append fields (map car default-values))))
-                (cond ((lset= eq? fields '(expected ...))
-                       #`(let* #,(field-bindings
-                                  #'((field value) (... ...)))
+              (let* ((provided-fields (map syntax->datum #'(field (... ...))))
+                     (duplicates (find-duplicates provided-fields))
+                     (fields (append provided-fields (map car default-values))))
+                (cond ((pair? duplicates)
+                       (record-error 'name s
+                                     "duplicate field initializers ~a"
+                                     duplicates))
+                      ((lset= eq? fields '(expected ...))
+                       #`(let* #,(field-bindings #'((field value) (... ...)))
                            (ctor #,@(map field-value '(expected ...)))))
                       ((pair? (lset-difference eq? fields
                                                '(expected ...)))
-- 
2.17.0