aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
author(unmatched-parenthesis d <paren@disroot.org>2023-04-28 20:19:03 +0100
committerJosselin Poiret <dev@jpoiret.xyz>2023-06-04 10:34:35 +0200
commitb88e38d4b51b9aa0e857baeb614c000e491ad309 (patch)
tree91980dbd49110d9b313ab9bc66d9a23ace67514a
parent1a4aace3af85bdfd5f513a4c5bb6925d1d0f50be (diff)
downloadguix-b88e38d4b51b9aa0e857baeb614c000e491ad309.tar.gz
guix-b88e38d4b51b9aa0e857baeb614c000e491ad309.zip
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>
-rw-r--r--guix/records.scm62
-rw-r--r--tests/records.scm29
2 files changed, 69 insertions, 22 deletions
diff --git a/guix/records.scm b/guix/records.scm
index d8966998c1..cfa46f0d80 100644
--- a/guix/records.scm
+++ b/guix/records.scm
@@ -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)
+ #'(values offset identity))
+ ((_ record field offset ((head delayed) tail ...))
(free-identifier=? #'field #'head)
- #'offset)
- ((_ field offset (_ tail ...))
- #'(lookup-field field (+ 1 offset) (tail ...))))))
+ #'(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 ...)
diff --git a/tests/records.scm b/tests/records.scm
index b1203dfeb7..4f0aeb3903 100644
--- a/tests/records.scm
+++ b/tests/records.scm
@@ -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)