nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

records: Allow thunked fields to refer to 'this-record'. 

* guix/records.scm (this-record): New syntax parameter.
(make-syntactic-constructor)[wrap-field-value]: When F is thunked,
return a one-argument lambda instead of a thunk, and parameterize
THIS-RECORD.
(define-record-type*)[thunked-field-accessor-definition]: Pass X
to (real-get X).
* tests/records.scm ("define-record-type* & thunked & this-record")
("define-record-type* & thunked & default & this-record")
("define-record-type* & thunked & inherit & this-record"): New tests.
This commit is contained in:
Ludovic Courtès 2019-03-22 14:02:00 +01:00
parent 3191b5f6ba
commit abd4d6b33d
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 62 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
guix/records.scm
View File

@ -25,6 +25,8 @@
#:use-module (ice-9 regex)
#:use-module (ice-9 rdelim)
#:export (define-record-type*
this-record
alist->record
object->fields
recutils->alist
@ -93,6 +95,17 @@ interface\" (ABI) for TYPE is equal to COOKIE."
(()
#t)))))))
(define-syntax-parameter this-record
(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-record
"cannot be used outside of a record instantiation"
#'id)))))
(define-syntax make-syntactic-constructor
(syntax-rules ()
"Make the syntactic constructor NAME for TYPE, that calls CTOR, and
@ -148,7 +161,14 @@ of TYPE matches the expansion-time ABI."
(define (wrap-field-value f value)
(cond ((thunked-field? f)
#`(lambda () #,value))
#`(lambda (x)
(syntax-parameterize ((this-record
(lambda (s)
(syntax-case s ()
(id
(identifier? #'id)
#'x)))))
#,value)))
((delayed-field? f)
#`(delay #,value))
(else value)))
@ -308,7 +328,7 @@ inherited."
(with-syntax ((real-get (wrapped-field-accessor-name field)))
#'(define-inlinable (get x)
;; The real value of that field is a thunk, so call it.
((real-get x)))))))
((real-get x) x))))))
(define (delayed-field-accessor-definition field)
;; Return the real accessor for FIELD, which is assumed to be a

40
tests/records.scm
View File

@ -170,6 +170,46 @@
(parameterize ((mark (cons 'a 'b)))
(eq? (foo-bar y) (mark)))))))
(test-assert "define-record-type* & thunked & this-record"
(begin
(define-record-type* <foo> foo make-foo
foo?
(bar foo-bar)
(baz foo-baz (thunked)))
(let ((x (foo (bar 40)
(baz (+ (foo-bar this-record) 2)))))
(and (= 40 (foo-bar x))
(= 42 (foo-baz x))))))
(test-assert "define-record-type* & thunked & default & this-record"
(begin
(define-record-type* <foo> foo make-foo
foo?
(bar foo-bar)
(baz foo-baz (thunked)
(default (+ (foo-bar this-record) 2))))
(let ((x (foo (bar 40))))
(and (= 40 (foo-bar x))
(= 42 (foo-baz x))))))
(test-assert "define-record-type* & thunked & inherit & this-record"
(begin
(define-record-type* <foo> foo make-foo
foo?
(bar foo-bar)
(baz foo-baz (thunked)
(default (+ (foo-bar this-record) 2))))
(let* ((x (foo (bar 40)))
(y (foo (inherit x) (bar -2)))
(z (foo (inherit x) (baz -2))))
(and (= -2 (foo-bar y))
(= 0 (foo-baz y))
(= 40 (foo-bar z))
(= -2 (foo-baz z))))))
(test-assert "define-record-type* & delayed"
(begin
(define-record-type* <foo> foo make-foo