ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

records: Support custom 'this' identifiers.

Browse source 
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.
This commit is contained in:
Ludovic Courtès 2019-03-29 22:40:55 +01:00
parent ec12e53736
commit d2be7e3c4b
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 47 additions and 3 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

32
guix/records.scm
View file

@ -118,6 +118,7 @@ (define-syntax make-syntactic-constructor
((_ type name ctor (expected ...)
#:abi-cookie abi-cookie
#:thunked thunked
#:this-identifier this-identifier
#:delayed delayed
#:innate innate
#:defaults defaults)
@ -162,7 +163,7 @@ (define (innate-field? f)
(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 @@ (define-syntax define-record-type*
(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 @@ (define-record-type* <thing> thing make-thing
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 @@ (define (compute-abi-cookie field-specs)
(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 @@ (define-record-type type
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 '()))

18
tests/records.scm
View file

@ -210,6 +210,24 @@ (define-record-type* <foo> foo make-foo
(= 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