aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix/utils.scm52
-rw-r--r--tests/utils.scm30
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)