diff options
| -rw-r--r-- | guix/utils.scm | 52 | ||||
| -rw-r--r-- | 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) |