[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
07/26: records: match-record: Support thunked and delayed fields.
From: |
guix-commits |
Subject: |
07/26: records: match-record: Support thunked and delayed fields. |
Date: |
Sun, 4 Jun 2023 05:38:32 -0400 (EDT) |
jpoiret pushed a commit to branch master
in repository guix.
commit b88e38d4b51b9aa0e857baeb614c000e491ad309
Author: (unmatched-parenthesis d <paren@disroot.org>
AuthorDate: Fri Apr 28 20:19:03 2023 +0100
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>
---
guix/records.scm | 62 +++++++++++++++++++++++++++++++++++--------------------
tests/records.scm | 29 ++++++++++++++++++++++++++
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)
- branch master updated (65bce4d9f9 -> cacc0cb6ab), guix-commits, 2023/06/04
- 01/26: services: screen-locker-service-type: Configurable PAM and setuid., guix-commits, 2023/06/04
- 05/26: gnu: sbsigntools: Update to 0.9.5., guix-commits, 2023/06/04
- 13/26: gnu: Add ghc-vector-hashtables., guix-commits, 2023/06/04
- 07/26: records: match-record: Support thunked and delayed fields.,
guix-commits <=
- 08/26: dir-locals: Fix MATCH-RECORD indentation., guix-commits, 2023/06/04
- 09/26: records: Add MATCH-RECORD-LAMBDA., guix-commits, 2023/06/04
- 20/26: build-system: New agda-build-system., guix-commits, 2023/06/04
- 11/26: tests: records: Add test for ellipsis in body., guix-commits, 2023/06/04
- 12/26: gnu: Add ghc-peano., guix-commits, 2023/06/04
- 26/26: channels: Raise an error if dependency's introduction is malformed, guix-commits, 2023/06/04
- 04/26: gnu: proot: Update to 5.4.0 and fix clone3 behavior., guix-commits, 2023/06/04
- 02/26: gnu: heimdal: Run autoreconf., guix-commits, 2023/06/04
- 03/26: gnu: heimdal: Drop obsolete and insecure user tools., guix-commits, 2023/06/04
- 06/26: records: match-record: Raise a syntax error if TYPE is nonexistent., guix-commits, 2023/06/04