diff options
| -rw-r--r-- | guix/records.scm | 62 | ||||
| -rw-r--r-- | 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) |