records: Add MATCH-RECORD-LAMBDA.

* guix/records.scm (match-record-lambda): New syntax.
* tests/records.scm ("match-record-lambda"): New test.

Signed-off-by: Josselin Poiret <dev@jpoiret.xyz>

.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))

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)

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

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)