12/13: records: Add 'define-record-type†'.

[Ludovic Courtès]

civodul pushed a commit to branch wip-service-refactor
in repository guix.

commit 3645318df0250948d01b5fd05eaab64e46091bcf
Author: Ludovic Courtès <address@hidden>
Date:   Tue Sep 22 00:03:37 2015 +0200

    records: Add 'define-record-type†'.
    
    * guix/records.scm (define-record-type†): New macro.
    * tests/records.scm ("define-record-type†"): New test.
---
 guix/records.scm  |   46 ++++++++++++++++++++++++++++++++++++++++++++++
 tests/records.scm |   10 ++++++++++
 2 files changed, 56 insertions(+), 0 deletions(-)

diff --git a/guix/records.scm b/guix/records.scm
index 0d35a74..ebb76b0 100644
--- a/guix/records.scm
+++ b/guix/records.scm
@@ -24,6 +24,7 @@
   #:use-module (ice-9 regex)
   #:use-module (ice-9 rdelim)
   #:export (define-record-type*
+            define-record-type†
             alist->record
             object->fields
             recutils->alist))
@@ -292,6 +293,51 @@ inherited."
                                            #:innate #,innate
                                            #:defaults #,defaults))))))))
 
+(define-syntax define-record-type†
+  (lambda (s)
+    "This is a variant of 'define-record-type*' that allows more concise code
+at the expense of generating identifiers \"non-hygienically\".  For example:
+
+  (define-record-type† foo bar baz (now (gettimeofday)))
+
+is equivalent to:
+
+  (define-record-type* <foo> foo make-foo foo?
+    (bar foo-bar)
+    (baz foo-baz)
+    (now foo-now (default (gettimeofday))))
+"
+    (syntax-case s ()
+      ((_ name fields ...)
+       (with-syntax ((rtd  (datum->syntax #'name
+                                          (symbol-append
+                                           '< (syntax->datum #'name) '>)))
+                     (pred (datum->syntax #'name
+                                          (symbol-append
+                                           (syntax->datum #'name) '?)))
+                     (ctor (datum->syntax #'name
+                                          (symbol-append
+                                           'make- (syntax->datum #'name)))))
+         (define (field-getter field)
+           (datum->syntax field
+                          (symbol-append (syntax->datum #'name) '-
+                                         (syntax->datum field))))
+
+         (define (field-specs fields)
+           (syntax-case fields ()
+             (((field dft) rest ...)
+              #`((field #,(field-getter #'field) (default dft))
+                 #,@(field-specs #'(rest ...))))
+             ((field rest ...)
+              #`((field #,(field-getter #'field))
+                 #,@(field-specs #'(rest ...))))
+             (()
+              #'())))
+
+         #`(define-record-type* rtd name ctor pred
+             #,@(field-specs #'(fields ...))))))))
+
+
 (define* (alist->record alist make keys
                         #:optional (multiple-value-keys '()))
   "Apply MAKE to the values associated with KEYS in ALIST.  Items in KEYS that
diff --git a/tests/records.scm b/tests/records.scm
index 800ed03..2b74206 100644
--- a/tests/records.scm
+++ b/tests/records.scm
@@ -261,6 +261,16 @@
       (and (string-match "extra.*initializer.*baz" message)
            (eq? proc 'foo)))))
 
+(test-assert "define-record-type†"
+  (let ()
+    (define-record-type† foo bar baz (frob 42))
+
+    (let* ((x (foo (bar 1) (baz 2)))
+           (y (foo (inherit x) (frob 77))))
+      (and (= (foo-bar x) 1) (= (foo-baz x) 2)
+           (= (foo-frob x) 42)
+           (match y (($ <foo> 1 2 77) #t))))))
+
 (test-equal "recutils->alist"
   '((("Name" . "foo")
      ("Version" . "0.1")