records: match-record: Support thunked and delayed fields.
* guix/records.scm (match-record): Unwrap matched thunked and delayed fields.
* tests/records.scm ("match-record, thunked field",
"match-record, delayed field"): New tests.
Signed-off-by: Josselin Poiret <dev@jpoiret.xyz>
This commit is contained in:
(unmatched-parenthesis d
Josselin Poiret
parent
1a4aace3af
commit
b88e38d4b5
@ -21,6 +21,7 @@
|
||||
#: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 @@ inherited."
|
||||
(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 @@ inherited."
|
||||
macro-expansion time."
|
||||
(syntax-case s (map-fields)
|
||||
((_ (map-fields _ _) macro)
|
||||
#'(macro (field ...)))
|
||||
#'(macro ((field field-type) ...)))
|
||||
(id
|
||||
(identifier? #'id)
|
||||
#'#,(rtd-identifier #'type)))))
|
||||
@ -578,30 +588,41 @@ pairs. Stop upon an empty line (after consuming it) or EOF."
|
||||
;;; 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."
|
||||
(syntax-case s ()
|
||||
((_ field offset ())
|
||||
(syntax-violation 'lookup-field "unknown record type field"
|
||||
"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."
|
||||
(syntax-case s (normal delayed thunked)
|
||||
((_ record field offset ())
|
||||
(syntax-violation 'match-record
|
||||
"unknown record type field"
|
||||
s #'field))
|
||||
((_ field offset (head tail ...))
|
||||
((_ record field offset ((head normal) tail ...))
|
||||
(free-identifier=? #'field #'head)
|
||||
#'offset)
|
||||
((_ field offset (_ tail ...))
|
||||
#'(lookup-field field (+ 1 offset) (tail ...))))))
|
||||
#'(values offset identity))
|
||||
((_ record field offset ((head delayed) tail ...))
|
||||
(free-identifier=? #'field #'head)
|
||||
#'(values offset force))
|
||||
((_ record field offset ((head thunked) tail ...))
|
||||
(free-identifier=? #'field #'head)
|
||||
#'(values offset (cut <> record)))
|
||||
((_ record field offset (_ tail ...))
|
||||
#'(lookup-field+wrapper record field
|
||||
(+ 1 offset) (tail ...))))))
|
||||
|
||||
(define-syntax match-record-inner
|
||||
(lambda (s)
|
||||
(syntax-case s ()
|
||||
((_ record type ((field variable) rest ...) body ...)
|
||||
#'(let-syntax ((field-offset (syntax-rules ()
|
||||
((_ f)
|
||||
(lookup-field 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 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 record type (rest ...) body ...))))
|
||||
((_ record type (field rest ...) body ...)
|
||||
;; Redirect to the canonical form above.
|
||||
@ -613,10 +634,7 @@ found."
|
||||
(syntax-rules ()
|
||||
"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."
|
||||
((_ record type (fields ...) body ...)
|
||||
(if (eq? (struct-vtable record) type)
|
||||
(match-record-inner record type (fields ...) body ...)
|
||||
|
||||
@ -561,4 +561,33 @@ Description: 1st line,
|
||||
(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)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user