diff options
| -rw-r--r-- | guix/records.scm | 20 | ||||
| -rw-r--r-- | tests/records.scm | 30 |
2 files changed, 46 insertions, 4 deletions
diff --git a/guix/records.scm b/guix/records.scm index 816e9f6f01..b68aaae1c4 100644 --- a/guix/records.scm +++ b/guix/records.scm @@ -51,6 +51,7 @@ fields, and DELAYED is the list of identifiers of delayed fields." ((_ type name ctor (expected ...) #:thunked thunked #:delayed delayed + #:innate innate #:defaults defaults) (define-syntax name (lambda (s) @@ -73,8 +74,11 @@ fields, and DELAYED is the list of identifiers of delayed fields." #`(make-struct type 0 #,@(map (lambda (field index) (or (field-inherited-value field) - #`(struct-ref #,orig-record - #,index))) + (if (innate-field? field) + (wrap-field-value + field (field-default-value field)) + #`(struct-ref #,orig-record + #,index)))) '(expected ...) (iota (length '(expected ...)))))) @@ -84,6 +88,9 @@ fields, and DELAYED is the list of identifiers of delayed fields." (define (delayed-field? f) (memq (syntax->datum f) 'delayed)) + (define (innate-field? f) + (memq (syntax->datum f) 'innate)) + (define (wrap-field-value f value) (cond ((thunked-field? f) #`(lambda () #,value)) @@ -164,7 +171,8 @@ may look like this: thing? (name thing-name (default \"chbouib\")) (port thing-port - (default (current-output-port)) (thunked))) + (default (current-output-port)) (thunked)) + (loc thing-location (innate) (default (current-source-location)))) This example defines a macro 'thing' that can be used to instantiate records of this type: @@ -190,7 +198,8 @@ It is possible to copy an object 'x' created with 'thing' like this: (thing (inherit x) (name \"bar\")) This expression returns a new object equal to 'x' except for its 'name' -field." +field and its 'loc' field---the latter is marked as \"innate\", so it is not +inherited." (define (field-default-value s) (syntax-case s (default) @@ -202,6 +211,7 @@ field." (define-field-property-predicate delayed-field? delayed) (define-field-property-predicate thunked-field? thunked) + (define-field-property-predicate innate-field? innate) (define (wrapped-field? s) (or (thunked-field? s) (delayed-field? s))) @@ -251,6 +261,7 @@ field." (let* ((field-spec #'((field get properties ...) ...)) (thunked (filter-map thunked-field? field-spec)) (delayed (filter-map delayed-field? field-spec)) + (innate (filter-map innate-field? field-spec)) (defaults (filter-map field-default-value #'((field properties ...) ...)))) (with-syntax (((field-spec* ...) @@ -278,6 +289,7 @@ field." (field ...) #:thunked #,thunked #:delayed #,delayed + #:innate #,innate #:defaults #,defaults)))))))) (define* (alist->record alist make keys diff --git a/tests/records.scm b/tests/records.scm index a00e38db7d..6346c154cd 100644 --- a/tests/records.scm +++ b/tests/records.scm @@ -90,6 +90,20 @@ (match b (($ <foo> 1 2) #t)) (equal? b c))))) +(test-assert "define-record-type* & inherit & innate" + (begin + (define-record-type* <foo> foo make-foo + foo? + (bar foo-bar (innate) (default 42))) + (let* ((a (foo (bar 1))) + (b (foo (inherit a))) + (c (foo (inherit a) (bar 3))) + (d (foo))) + (and (match a (($ <foo> 1) #t)) + (match b (($ <foo> 42) #t)) + (match c (($ <foo> 3) #t)) + (match d (($ <foo> 42) #t)))))) + (test-assert "define-record-type* & thunked" (begin (define-record-type* <foo> foo make-foo @@ -139,6 +153,22 @@ (parameterize ((mark (cons 'a 'b))) (eq? (foo-baz y) (mark)))))))) +(test-assert "define-record-type* & thunked & innate" + (let ((mark (make-parameter #f))) + (define-record-type* <foo> foo make-foo + foo? + (bar foo-bar (thunked) (innate) (default (mark))) + (baz foo-baz (default #f))) + + (let* ((x (foo (bar 42))) + (y (foo (inherit x) (baz 'unused)))) + (and (procedure? (struct-ref x 0)) + (equal? (foo-bar x) 42) + (parameterize ((mark (cons 'a 'b))) + (eq? (foo-bar y) (mark))) + (parameterize ((mark (cons 'a 'b))) + (eq? (foo-bar y) (mark))))))) + (test-assert "define-record-type* & delayed" (begin (define-record-type* <foo> foo make-foo |