From dcd60f439830ba58f7b89f028973e77ed414cb86 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Thu, 30 Aug 2012 00:18:50 +0200
Subject: [PATCH] define-record-type*: Add the `inherit' syntactic constructor
 keyword.

* guix/utils.scm (define-record-type*)[make-syntactic-constructor]: New
  `type' parameter.  Add the `inherit' keyword and corresponding support
  code.

* tests/utils.scm ("define-record-type* & inherit", "define-record-type*
  & inherit & letrec* behavior"): New tests.
---
 guix/utils.scm  | 52 ++++++++++++++++++++++++++++++++++++-------------
 tests/utils.scm | 30 ++++++++++++++++++++++++++++
 2 files changed, 68 insertions(+), 14 deletions(-)

diff --git a/guix/utils.scm b/guix/utils.scm
index 686175947e..cec6df935b 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -477,17 +477,41 @@ starting from the right of S."
     "Define the given record type such that an additional \"syntactic
 constructor\" is defined, which allows instances to be constructed with named
 field initializers, à la SRFI-35, as well as default values."
-    (define (make-syntactic-constructor name ctor fields defaults)
-      "Make the syntactic constructor NAME that calls CTOR, and expects all
-of FIELDS to be initialized.  DEFAULTS is the list of FIELD/DEFAULT-VALUE
-tuples."
-      (with-syntax ((name     name)
+    (define (make-syntactic-constructor type name ctor fields defaults)
+      "Make the syntactic constructor NAME for TYPE, that calls CTOR, and
+expects all of FIELDS to be initialized.  DEFAULTS is the list of
+FIELD/DEFAULT-VALUE tuples."
+      (with-syntax ((type     type)
+                    (name     name)
                     (ctor     ctor)
                     (expected fields)
                     (defaults defaults))
-        #'(define-syntax name
+        #`(define-syntax name
             (lambda (s)
-              (syntax-case s expected
+              (define (record-inheritance orig-record field+value)
+                ;; Produce code that returns a record identical to
+                ;; ORIG-RECORD, except that values for the FIELD+VALUE alist
+                ;; prevail.
+                (define (field-inherited-value f)
+                  (and=> (find (lambda (x)
+                                 (eq? f (car (syntax->datum x))))
+                               field+value)
+                         car))
+
+                #`(make-struct type 0
+                               #,@(map (lambda (field index)
+                                         (or (field-inherited-value field)
+                                             #`(struct-ref #,orig-record
+                                                           #,index)))
+                                       'expected
+                                       (iota (length 'expected)))))
+
+
+              (syntax-case s (inherit #,@fields)
+                ((_ (inherit orig-record) (field value) (... ...))
+                 #`(letrec* ((field value) (... ...))
+                     #,(record-inheritance #'orig-record
+                                           #'((field value) (... ...)))))
                 ((_ (field value) (... ...))
                  (let ((fields (map syntax->datum #'(field (... ...))))
                        (dflt   (map (match-lambda
@@ -495,12 +519,12 @@ tuples."
                                       (list (syntax->datum f) v)))
                                     #'defaults)))
 
-                    (define (field-value f)
-                      (or (and=> (find (lambda (x)
-                                         (eq? f (car (syntax->datum x))))
-                                       #'((field value) (... ...)))
-                                 car)
-                          (car (assoc-ref dflt (syntax->datum f)))))
+                   (define (field-value f)
+                     (or (and=> (find (lambda (x)
+                                        (eq? f (car (syntax->datum x))))
+                                      #'((field value) (... ...)))
+                                car)
+                         (car (assoc-ref dflt (syntax->datum f)))))
 
                    (let-syntax ((error*
                                  (syntax-rules ()
@@ -537,7 +561,7 @@ tuples."
              (ctor field ...)
              pred
              (field get) ...)
-           #,(make-syntactic-constructor #'syntactic-ctor #'ctor
+           #,(make-syntactic-constructor #'type #'syntactic-ctor #'ctor
                                          #'(field ...)
                                          (filter-map field-default-value
                                                      #'((field options ...)
diff --git a/tests/utils.scm b/tests/utils.scm
index 6a90817ec3..a0b42052ad 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -132,6 +132,36 @@
          (match (bar (z 21) (x (/ z 3)))
            (($ <bar> 7 42 21))))))
 
+(test-assert "define-record-type* & inherit"
+  (begin
+    (define-record-type* <foo> foo make-foo
+      foo?
+      (bar foo-bar)
+      (baz foo-baz (default (+ 40 2))))
+    (let* ((a (foo (bar 1)))
+           (b (foo (inherit a) (baz 2)))
+           (c (foo (inherit b) (bar -2)))
+           (d (foo (inherit c)))
+           (e (foo (inherit (foo (bar 42))) (baz 77))))
+     (and (match a (($ <foo> 1 42) #t))
+          (match b (($ <foo> 1 2) #t))
+          (match c (($ <foo> -2 2) #t))
+          (equal? c d)
+          (match e (($ <foo> 42 77) #t))))))
+
+(test-assert "define-record-type* & inherit & letrec* behavior"
+  (begin
+    (define-record-type* <foo> foo make-foo
+      foo?
+      (bar foo-bar)
+      (baz foo-baz (default (+ 40 2))))
+    (let* ((a (foo (bar 77)))
+           (b (foo (inherit a) (bar 1) (baz (+ bar 1))))
+           (c (foo (inherit b) (baz 2) (bar (- baz 1)))))
+     (and (match a (($ <foo> 77 42) #t))
+          (match b (($ <foo> 1 2) #t))
+          (equal? b c)))))
+
 (test-end)