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.
This commit is contained in:
parent
c79dae6076
commit
dcd60f4398
|
@ -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 ...)
|
||||
|
|
|
@ -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)
|
||||
|
||||
|
||||
|
|
Loading…
Reference in New Issue