diff options
| -rw-r--r-- | .dir-locals.el | 1 | ||||
| -rw-r--r-- | guix/read-print.scm | 1 | ||||
| -rw-r--r-- | guix/records.scm | 14 | ||||
| -rw-r--r-- | tests/records.scm | 12 |
4 files changed, 27 insertions, 1 deletions
diff --git a/.dir-locals.el b/.dir-locals.el index 3ffd25ee94..d79b5c9d7e 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -71,6 +71,7 @@ (eval . (put 'lambda* 'scheme-indent-function 1)) (eval . (put 'substitute* 'scheme-indent-function 1)) (eval . (put 'match-record 'scheme-indent-function 3)) + (eval . (put 'match-record-lambda 'scheme-indent-function 2)) ;; TODO: Contribute these to Emacs' scheme-mode. (eval . (put 'let-keywords 'scheme-indent-function 3)) diff --git a/guix/read-print.scm b/guix/read-print.scm index 04dc0dcfbe..25be289d60 100644 --- a/guix/read-print.scm +++ b/guix/read-print.scm @@ -319,6 +319,7 @@ expressions and blanks that were read." ('letrec* 2) ('match 2) ('match-record 3) + ('match-record-lambda 2) ('when 2) ('unless 2) ('package 1) diff --git a/guix/records.scm b/guix/records.scm index cfa46f0d80..2a88cb4b3c 100644 --- a/guix/records.scm +++ b/guix/records.scm @@ -31,7 +31,8 @@ alist->record object->fields recutils->alist - match-record)) + match-record + match-record-lambda)) ;;; Commentary: ;;; @@ -640,4 +641,15 @@ an unknown field is queried." (match-record-inner record type (fields ...) body ...) (throw 'wrong-type-arg record))))) +(define-syntax match-record-lambda + (syntax-rules () + "Return a procedure accepting a single record of the given TYPE for which each +FIELD will be bound to its FIELD name within the returned procedure. A syntax error +is raised if an unknown field is queried." + ((_ type (field ...) body ...) + (lambda (record) + (if (eq? (struct-vtable record) type) + (match-record-inner record type (field ...) body ...) + (throw 'wrong-type-arg record)))))) + ;;; records.scm ends here diff --git a/tests/records.scm b/tests/records.scm index 4f0aeb3903..8ee306bddc 100644 --- a/tests/records.scm +++ b/tests/records.scm @@ -590,4 +590,16 @@ Description: 1st line, (match-record rec <with-thunked> (normal thunked) (list normal thunked))))) +(test-equal "match-record-lambda" + '("thing: foo" "thing: bar") + (begin + (define-record-type* <with-text> with-text make-with-text + with-text? + (text with-text-text)) + + (map (match-record-lambda <with-text> (text) + (string-append "thing: " text)) + (list (with-text (text "foo")) + (with-text (text "bar")))))) + (test-end) |