@@ -21,6 +21,7 @@ (define-module (guix records)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-71)
#:use-module (ice-9 match)
#:use-module (ice-9 rdelim)
#:autoload (system base target) (target-most-positive-fixnum)
@@ -428,10 +429,19 @@ (define (compute-abi-cookie field-specs)
(defaults (filter-map field-default-value
#'((field properties ...) ...)))
(sanitizers (filter-map field-sanitizer
- #'((field properties ...) ...)))
+ #'((field properties ...) ...)))
(cookie (compute-abi-cookie field-spec)))
(with-syntax (((field-spec* ...)
(map field-spec->srfi-9 field-spec))
+ ((field-type ...)
+ (map (match-lambda
+ ((? thunked-field?)
+ (datum->syntax s 'thunked))
+ ((? delayed-field?)
+ (datum->syntax s 'delayed))
+ (else
+ (datum->syntax s 'normal)))
+ field-spec))
((thunked-field-accessor ...)
(filter-map (lambda (field)
(and (thunked-field? field)
@@ -465,7 +475,7 @@ (define-syntax type
macro-expansion time."
(syntax-case s (map-fields)
((_ (map-fields _ _) macro)
- #'(macro (field ...)))
+ #'(macro ((field field-type) ...)))
(id
(identifier? #'id)
#'#,(rtd-identifier #'type)))))
@@ -578,31 +588,42 @@ (define (recutils->alist port)
;;; Pattern matching.
;;;
-(define-syntax lookup-field
+(define-syntax lookup-field+wrapper
(lambda (s)
- "Look up FIELD in the given list and return an expression that represents
-its offset in the record. Raise a syntax violation when the field is not
-found, displaying it as originating in form S*."
- (syntax-case s ()
- ((_ s* field offset ())
+ "Look up FIELD in the given list and return both an expression that represents
+its offset in the record and a procedure that wraps it to return its \"true\" value
+(for instance, FORCE is returned in the case of a delayed field). RECORD is passed
+to thunked values. Raise a syntax violation when the field is not found, displaying
+it as originating in form S*."
+ (syntax-case s (normal delayed thunked)
+ ((_ s* record field offset ())
(syntax-violation 'match-record
"unknown record type field"
#'s* #'field))
- ((_ s* field offset (head tail ...))
+ ((_ s* record field offset ((head normal) tail ...))
+ (free-identifier=? #'field #'head)
+ #'(values offset identity))
+ ((_ s* record field offset ((head delayed) tail ...))
(free-identifier=? #'field #'head)
- #'offset)
- ((_ s* field offset (_ tail ...))
- #'(lookup-field s* field (+ 1 offset) (tail ...))))))
+ #'(values offset force))
+ ((_ s* record field offset ((head thunked) tail ...))
+ (free-identifier=? #'field #'head)
+ #'(values offset (cut <> record)))
+ ((_ s* record field offset (_ tail ...))
+ #'(lookup-field+wrapper s* record field
+ (+ 1 offset) (tail ...))))))
(define-syntax match-record-inner
(lambda (s)
(syntax-case s ()
((_ s* record type ((field variable) rest ...) body ...)
- #'(let-syntax ((field-offset (syntax-rules ()
- ((_ f)
- (lookup-field s* field 0 f)))))
- (let* ((offset (type (map-fields type match-record) field-offset))
- (variable (struct-ref record offset)))
+ #'(let-syntax ((field-offset+wrapper
+ (syntax-rules ()
+ ((_ f)
+ (lookup-field+wrapper s* record field 0 f)))))
+ (let* ((offset wrap (type (map-fields type match-record)
+ field-offset+wrapper))
+ (variable (wrap (struct-ref record offset))))
(match-record-inner s* record type (rest ...) body ...))))
((_ s* record type (field rest ...) body ...)
;; Redirect to the canonical form above.
@@ -614,10 +635,7 @@ (define-syntax match-record
(lambda (s)
"Bind each FIELD of a RECORD of the given TYPE to it's FIELD name.
The order in which fields appear does not matter. A syntax error is raised if
-an unknown field is queried.
-
-The current implementation does not support thunked and delayed fields."
- ;; TODO support thunked and delayed fields
+an unknown field is queried."
(syntax-case s ()
((_ record type (fields ...) body ...)
#`(if (eq? (struct-vtable record) type)
@@ -561,4 +561,33 @@ (define-record-type* <foo> foo make-foo
(make-fresh-user-module)))
(lambda (key . args) key)))
+(test-equal "match-record, delayed field"
+ "foo bar bar foo"
+ (begin
+ (define-record-type* <with-delayed> with-delayed make-with-delayed
+ with-delayed?
+ (delayed with-delayed-delayed
+ (delayed)))
+
+ (let ((rec (with-delayed
+ (delayed "foo bar bar foo"))))
+ (match-record rec <with-delayed> (delayed)
+ delayed))))
+
+(test-equal "match-record, thunked field"
+ '("foo" "foobar")
+ (begin
+ (define-record-type* <with-thunked> with-thunked make-with-thunked
+ with-thunked?
+ (normal with-thunked-normal)
+ (thunked with-thunked-thunked
+ (thunked)))
+
+ (let ((rec (with-thunked
+ (normal "foo")
+ (thunked (string-append (with-thunked-normal this-record)
+ "bar")))))
+ (match-record rec <with-thunked> (normal thunked)
+ (list normal thunked)))))
+
(test-end)
* guix/records.scm (match-record): Unwrap matched thunked and delayed fields. * tests/records.scm ("match-record, thunked field", "match-record, delayed field"): New tests. --- guix/records.scm | 60 ++++++++++++++++++++++++++++++----------------- tests/records.scm | 29 +++++++++++++++++++++++ 2 files changed, 68 insertions(+), 21 deletions(-)