summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.dir-locals.el1
-rw-r--r--guix/read-print.scm1
-rw-r--r--guix/records.scm14
-rw-r--r--tests/records.scm12
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)