From 5291fd7a4205394b863a8705b32fbb447321dc60 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Thu, 20 May 2021 15:40:55 +0200
Subject: records: Support field sanitizers.

* guix/records.scm (make-syntactic-constructor): Add #:sanitizers.
[field-sanitizer]: New procedure.
[wrap-field-value]: Honor F's sanitizer.
(define-record-type*)[field-sanitizer]: New procedure.
Pass #:sanitizer to 'make-syntactic-constructor'.
* tests/records.scm ("define-record-type* & sanitize")
("define-record-type* & sanitize & thunked"): New tests.
---
 tests/records.scm | 38 ++++++++++++++++++++++++++++++++++++++
 1 file changed, 38 insertions(+)

(limited to 'tests/records.scm')

diff --git a/tests/records.scm b/tests/records.scm
index 706bb3dbfd..d014e7a995 100644
--- a/tests/records.scm
+++ b/tests/records.scm
@@ -283,6 +283,44 @@ (define-record-type* <foo> foo make-foo
              (equal? (foo-bar y) 1))              ;promise was already forced
            (eq? (foo-baz y) 'b)))))
 
+(test-assert "define-record-type* & sanitize"
+  (begin
+    (define-record-type* <foo> foo make-foo
+      foo?
+      (bar foo-bar
+           (default "bar")
+           (sanitize (lambda (x) (string-append x "!")))))
+
+    (let* ((p (foo))
+           (q (foo (inherit p)))
+           (r (foo (inherit p) (bar "baz")))
+           (s (foo (bar "baz"))))
+      (and (string=? (foo-bar p) "bar!")
+           (equal? q p)
+           (string=? (foo-bar r) "baz!")
+           (equal? s r)))))
+
+(test-assert "define-record-type* & sanitize & thunked"
+  (let ((sanitized 0))
+    (define-record-type* <foo> foo make-foo
+      foo?
+      (bar foo-bar
+           (default "bar")
+           (sanitize (lambda (x)
+                       (set! sanitized (+ 1 sanitized))
+                       (string-append x "!")))))
+
+    (let ((p (foo)))
+      (and (string=? (foo-bar p) "bar!")
+           (string=? (foo-bar p) "bar!")          ;twice
+           (= sanitized 1)             ;sanitizer was called at init time only
+           (let ((q (foo (bar "baz"))))
+             (and (string=? (foo-bar q) "baz!")
+                  (string=? (foo-bar q) "baz!")   ;twice
+                  (= sanitized 2)
+                  (let ((r (foo (inherit q))))
+                    (and (string=? (foo-bar r) "baz!")
+                         (= sanitized 2)))))))))  ;no re-sanitization
 (test-assert "define-record-type* & wrong field specifier"
   (let ((exp '(begin
                 (define-record-type* <foo> foo make-foo
-- 
cgit v1.2.3