summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2019-03-29 22:40:55 +0100
committerLudovic Courtès <ludo@gnu.org>2019-03-30 11:08:39 +0100
commitd2be7e3c4ba8d6d0dde9b4c0bff623ab85637424 (patch)
treea9be7eae8e45656e1d6fe9943d4f7e29fe34944a
parentec12e53736f212d700587e096ebee15ffc118c46 (diff)
downloadpatches-d2be7e3c4ba8d6d0dde9b4c0bff623ab85637424.tar
patches-d2be7e3c4ba8d6d0dde9b4c0bff623ab85637424.tar.gz
records: Support custom 'this' identifiers.
This lets record users choose an identifier other than 'this-record'. * guix/records.scm (make-syntactic-constructor): Add #:this-identifier. [wrap-field-value]: Honor it. (define-record-type*): Add form with extra THIS-IDENTIFIER and honor it. * tests/records.scm ("define-record-type* & thunked & inherit & custom this"): New test.
-rw-r--r--guix/records.scm32
-rw-r--r--tests/records.scm18
2 files changed, 47 insertions, 3 deletions
diff --git a/guix/records.scm b/guix/records.scm
index 244b124098..99507dc384 100644
--- a/guix/records.scm
+++ b/guix/records.scm
@@ -118,6 +118,7 @@ of TYPE matches the expansion-time ABI."
((_ type name ctor (expected ...)
#:abi-cookie abi-cookie
#:thunked thunked
+ #:this-identifier this-identifier
#:delayed delayed
#:innate innate
#:defaults defaults)
@@ -162,7 +163,7 @@ of TYPE matches the expansion-time ABI."
(define (wrap-field-value f value)
(cond ((thunked-field? f)
#`(lambda (x)
- (syntax-parameterize ((this-record
+ (syntax-parameterize ((#,this-identifier
(lambda (s)
(syntax-case s ()
(id
@@ -254,6 +255,7 @@ may look like this:
(define-record-type* <thing> thing make-thing
thing?
+ this-thing
(name thing-name (default \"chbouib\"))
(port thing-port
(default (current-output-port)) (thunked))
@@ -273,7 +275,8 @@ default value specified in the 'define-record-type*' form is used:
The 'port' field is \"thunked\", meaning that calls like '(thing-port x)' will
actually compute the field's value in the current dynamic extent, which is
-useful when referring to fluids in a field's value.
+useful when referring to fluids in a field's value. Furthermore, that thunk
+can access the record it belongs to via the 'this-thing' identifier.
A field can also be marked as \"delayed\" instead of \"thunked\", in which
case its value is effectively wrapped in a (delay …) form.
@@ -352,7 +355,9 @@ inherited."
(syntax-case s ()
((_ type syntactic-ctor ctor pred
+ this-identifier
(field get properties ...) ...)
+ (identifier? #'this-identifier)
(let* ((field-spec #'((field get properties ...) ...))
(thunked (filter-map thunked-field? field-spec))
(delayed (filter-map delayed-field? field-spec))
@@ -381,15 +386,36 @@ inherited."
field-spec* ...)
(define #,(current-abi-identifier #'type)
#,cookie)
+
+ #,@(if (free-identifier=? #'this-identifier #'this-record)
+ #'()
+ #'((define-syntax-parameter this-identifier
+ (lambda (s)
+ "Return the record being defined. This macro may
+only be used in the context of the definition of a thunked field."
+ (syntax-case s ()
+ (id
+ (identifier? #'id)
+ (syntax-violation 'this-identifier
+ "cannot be used outside \
+of a record instantiation"
+ #'id)))))))
thunked-field-accessor ...
delayed-field-accessor ...
(make-syntactic-constructor type syntactic-ctor ctor
(field ...)
#:abi-cookie #,cookie
#:thunked #,thunked
+ #:this-identifier #'this-identifier
#:delayed #,delayed
#:innate #,innate
- #:defaults #,defaults))))))))
+ #:defaults #,defaults)))))
+ ((_ type syntactic-ctor ctor pred
+ (field get properties ...) ...)
+ ;; When no 'this' identifier was specified, use 'this-record'.
+ #'(define-record-type* type syntactic-ctor ctor pred
+ this-record
+ (field get properties ...) ...)))))
(define* (alist->record alist make keys
#:optional (multiple-value-keys '()))
diff --git a/tests/records.scm b/tests/records.scm
index 45614093a0..16b7a9c35e 100644
--- a/tests/records.scm
+++ b/tests/records.scm
@@ -210,6 +210,24 @@
(= 40 (foo-bar z))
(= -2 (foo-baz z))))))
+(test-assert "define-record-type* & thunked & inherit & custom this"
+ (let ()
+ (define-record-type* <foo> foo make-foo
+ foo? this-foo
+ (thing foo-thing (thunked)))
+ (define-record-type* <bar> bar make-bar
+ bar? this-bar
+ (baz bar-baz (thunked)))
+
+ ;; Nest records and test the two self references.
+ (let* ((x (foo (thing (bar (baz (list this-bar this-foo))))))
+ (y (foo-thing x)))
+ (match (bar-baz y)
+ ((first second)
+ (and (eq? second x)
+ (bar? first)
+ (eq? first y)))))))
+
(test-assert "define-record-type* & delayed"
(begin
(define-record-type* <foo> foo make-foo