summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2021-05-20 15:40:55 +0200
committerLudovic Courtès <ludo@gnu.org>2021-08-12 12:34:13 +0200
commit5291fd7a4205394b863a8705b32fbb447321dc60 (patch)
tree6ccbfe1bab6a4a995082e2f9df659816ddb2f6dd
parent1ad0da60d81f4ba59f5f97af930e9b09f561d277 (diff)
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.
-rw-r--r--guix/records.scm65
-rw-r--r--tests/records.scm38
2 files changed, 89 insertions, 14 deletions
diff --git a/guix/records.scm b/guix/records.scm
index 3d54a51956..ed94c83dac 100644
--- a/guix/records.scm
+++ b/guix/records.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Mark H Weaver <mhw@netris.org>
;;;
;;; This file is part of GNU Guix.
@@ -120,7 +120,8 @@ context of the definition of a thunked field."
"Make the syntactic constructor NAME for TYPE, that calls CTOR, and
expects all of EXPECTED fields to be initialized. DEFAULTS is the list of
FIELD/DEFAULT-VALUE tuples, THUNKED is the list of identifiers of thunked
-fields, and DELAYED is the list of identifiers of delayed fields.
+fields, DELAYED is the list of identifiers of delayed fields, and SANITIZERS
+is the list of FIELD/SANITIZER tuples.
ABI-COOKIE is the cookie (an integer) against which to check the run-time ABI
of TYPE matches the expansion-time ABI."
@@ -130,6 +131,7 @@ of TYPE matches the expansion-time ABI."
#:this-identifier this-identifier
#:delayed delayed
#:innate innate
+ #:sanitizers sanitizers
#:defaults defaults)
(define-syntax name
(lambda (s)
@@ -169,19 +171,30 @@ of TYPE matches the expansion-time ABI."
(define (innate-field? f)
(memq (syntax->datum f) 'innate))
+ (define field-sanitizer
+ (let ((lst (map (match-lambda
+ ((f p)
+ (list (syntax->datum f) p)))
+ #'sanitizers)))
+ (lambda (f)
+ (or (and=> (assoc-ref lst (syntax->datum f)) car)
+ #'(lambda (x) x)))))
+
(define (wrap-field-value f value)
- (cond ((thunked-field? f)
- #`(lambda (x)
- (syntax-parameterize ((#,this-identifier
- (lambda (s)
- (syntax-case s ()
- (id
- (identifier? #'id)
- #'x)))))
- #,value)))
- ((delayed-field? f)
- #`(delay #,value))
- (else value)))
+ (let* ((sanitizer (field-sanitizer f))
+ (value #`(#,sanitizer #,value)))
+ (cond ((thunked-field? f)
+ #`(lambda (x)
+ (syntax-parameterize ((#,this-identifier
+ (lambda (s)
+ (syntax-case s ()
+ (id
+ (identifier? #'id)
+ #'x)))))
+ #,value)))
+ ((delayed-field? f)
+ #`(delay #,value))
+ (else value))))
(define default-values
;; List of symbol/value tuples.
@@ -291,6 +304,19 @@ can access the record it belongs to via the 'this-thing' identifier.
A field can also be marked as \"delayed\" instead of \"thunked\", in which
case its value is effectively wrapped in a (delay …) form.
+A field can also have an associated \"sanitizer\", which is a procedure that
+takes a user-supplied field value and returns a \"sanitized\" value for the
+field:
+
+ (define-record-type* <thing> thing make-thing
+ thing?
+ this-thing
+ (name thing-name
+ (sanitize (lambda (value)
+ (cond ((string? value) value)
+ ((symbol? value) (symbol->string value))
+ (else (throw 'bad! value)))))))
+
It is possible to copy an object 'x' created with 'thing' like this:
(thing (inherit x) (name \"bar\"))
@@ -307,6 +333,14 @@ inherited."
(field-default-value #'(field properties ...)))
(_ #f)))
+ (define (field-sanitizer s)
+ (syntax-case s (sanitize)
+ ((field (sanitize proc) _ ...)
+ (list #'field #'proc))
+ ((field _ properties ...)
+ (field-sanitizer #'(field properties ...)))
+ (_ #f)))
+
(define-field-property-predicate delayed-field? delayed)
(define-field-property-predicate thunked-field? thunked)
(define-field-property-predicate innate-field? innate)
@@ -376,6 +410,8 @@ inherited."
(innate (filter-map innate-field? field-spec))
(defaults (filter-map field-default-value
#'((field properties ...) ...)))
+ (sanitizers (filter-map field-sanitizer
+ #'((field properties ...) ...)))
(cookie (compute-abi-cookie field-spec)))
(with-syntax (((field-spec* ...)
(map field-spec->srfi-9 field-spec))
@@ -421,6 +457,7 @@ of a record instantiation"
#:this-identifier #'this-identifier
#:delayed #,delayed
#:innate #,innate
+ #:sanitizers #,sanitizers
#:defaults #,defaults)))))
((_ type syntactic-ctor ctor pred
(field get properties ...) ...)
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 @@
(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