me
/
guix
Archived
1
0
Fork 0
Code

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>
master
(unmatched-parenthesis d 2023-04-28 20:19:03 +01:00 committed by Josselin Poiret
parent 1a4aace3af
commit b88e38d4b5
No known key found for this signature in database
GPG Key ID: 505E40B916171A8A
2 changed files with 69 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

62
guix/records.scm
View File

@ -21,6 +21,7 @@
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (srfi srfi-71)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 rdelim) #:use-module (ice-9 rdelim)
#:autoload (system base target) (target-most-positive-fixnum) #:autoload (system base target) (target-most-positive-fixnum)
@ -428,10 +429,19 @@ inherited."
(defaults (filter-map field-default-value (defaults (filter-map field-default-value
#'((field properties ...) ...))) #'((field properties ...) ...)))
(sanitizers (filter-map field-sanitizer (sanitizers (filter-map field-sanitizer
#'((field properties ...) ...))) #'((field properties ...) ...)))
(cookie (compute-abi-cookie field-spec))) (cookie (compute-abi-cookie field-spec)))
(with-syntax (((field-spec* ...) (with-syntax (((field-spec* ...)
(map field-spec->srfi-9 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 ...) ((thunked-field-accessor ...)
(filter-map (lambda (field) (filter-map (lambda (field)
(and (thunked-field? field) (and (thunked-field? field)
@ -465,7 +475,7 @@ inherited."
macro-expansion time." macro-expansion time."
(syntax-case s (map-fields) (syntax-case s (map-fields)
((_ (map-fields _ _) macro) ((_ (map-fields _ _) macro)
#'(macro (field ...))) #'(macro ((field field-type) ...)))
(id (id
(identifier? #'id) (identifier? #'id)
#'#,(rtd-identifier #'type))))) #'#,(rtd-identifier #'type)))))
@ -578,30 +588,41 @@ pairs. Stop upon an empty line (after consuming it) or EOF."
;;; Pattern matching. ;;; Pattern matching.
;;; ;;;
(define-syntax lookup-field (define-syntax lookup-field+wrapper
(lambda (s) (lambda (s)
"Look up FIELD in the given list and return an expression that represents "Look up FIELD in the given list and return both an expression that represents
its offset in the record. Raise a syntax violation when the field is not its offset in the record and a procedure that wraps it to return its \"true\" value
found." (for instance, FORCE is returned in the case of a delayed field). RECORD is passed
(syntax-case s () to thunked values. Raise a syntax violation when the field is not found."
((_ field offset ()) (syntax-case s (normal delayed thunked)
(syntax-violation 'lookup-field "unknown record type field" ((_ record field offset ())
(syntax-violation 'match-record
"unknown record type field"
s #'field)) s #'field))
((_ field offset (head tail ...)) ((_ record field offset ((head normal) tail ...))
(free-identifier=? #'field #'head) (free-identifier=? #'field #'head)
#'offset) #'(values offset identity))
((_ field offset (_ tail ...)) ((_ record field offset ((head delayed) tail ...))
#'(lookup-field field (+ 1 offset) (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 (define-syntax match-record-inner
(lambda (s) (lambda (s)
(syntax-case s () (syntax-case s ()
((_ record type ((field variable) rest ...) body ...) ((_ record type ((field variable) rest ...) body ...)
#'(let-syntax ((field-offset (syntax-rules () #'(let-syntax ((field-offset+wrapper
((_ f) (syntax-rules ()
(lookup-field field 0 f))))) ((_ f)
(let* ((offset (type (map-fields type match-record) field-offset)) (lookup-field+wrapper record field 0 f)))))
(variable (struct-ref record offset))) (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 ...)))) (match-record-inner record type (rest ...) body ...))))
((_ record type (field rest ...) body ...) ((_ record type (field rest ...) body ...)
;; Redirect to the canonical form above. ;; Redirect to the canonical form above.
@ -613,10 +634,7 @@ found."
(syntax-rules () (syntax-rules ()
"Bind each FIELD of a RECORD of the given TYPE to it's FIELD name. "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 The order in which fields appear does not matter. A syntax error is raised if
an unknown field is queried. an unknown field is queried."
The current implementation does not support thunked and delayed fields."
;; TODO support thunked and delayed fields
((_ record type (fields ...) body ...) ((_ record type (fields ...) body ...)
(if (eq? (struct-vtable record) type) (if (eq? (struct-vtable record) type)
(match-record-inner record type (fields ...) body ...) (match-record-inner record type (fields ...) body ...)

29
tests/records.scm
View File

@ -561,4 +561,33 @@ Description: 1st line,
(make-fresh-user-module))) (make-fresh-user-module)))
(lambda (key . args) key))) (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) (test-end)