diff options
author | (unmatched-parenthesis d <paren@disroot.org> | 2023-04-28 20:19:03 +0100 |
---|---|---|
committer | Josselin Poiret <dev@jpoiret.xyz> | 2023-06-04 10:34:35 +0200 |
commit | b88e38d4b51b9aa0e857baeb614c000e491ad309 (patch) | |
tree | 91980dbd49110d9b313ab9bc66d9a23ace67514a /guix/records.scm | |
parent | 1a4aace3af85bdfd5f513a4c5bb6925d1d0f50be (diff) | |
download | guix-patches-b88e38d4b51b9aa0e857baeb614c000e491ad309.tar guix-patches-b88e38d4b51b9aa0e857baeb614c000e491ad309.tar.gz |
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>
Diffstat (limited to 'guix/records.scm')
-rw-r--r-- | guix/records.scm | 62 |
1 files changed, 40 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 ...) |