From dcd60f439830ba58f7b89f028973e77ed414cb86 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Thu, 30 Aug 2012 00:18:50 +0200
Subject: 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 ++++++++++++++++++++++++++++++++++++++--------------
 1 file changed, 38 insertions(+), 14 deletions(-)

(limited to 'guix/utils.scm')

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 ...)
-- 
cgit v1.2.3