me
/
guix
Archived
1
0
Fork 0
Code

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.
master
Ludovic Courtès 2021-05-20 15:40:55 +02:00
parent 2a3cd4ee35
commit 8be1632199
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 89 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

65
guix/records.scm
View File

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

38
tests/records.scm
View File

@ -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