ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

records: Support field sanitizers.

Browse source 
* 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.
This commit is contained in:
Ludovic Courtès 2021-05-20 15:40:55 +02:00
parent 1ad0da60d8
commit 5291fd7a42
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 @@ (define-syntax make-syntactic-constructor
"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 @@ (define-syntax make-syntactic-constructor
#:this-identifier this-identifier
#:delayed delayed
#:innate innate
#:sanitizers sanitizers
#:defaults defaults)
(define-syntax name
(lambda (s)
@ -169,19 +171,30 @@ (define (delayed-field? f)
(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 @@ (define-record-type* <thing> thing make-thing
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 @@ (define (field-default-value s)
(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 @@ (define (compute-abi-cookie field-specs)
(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 @@ (define #,(current-abi-identifier #'type)
#: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 @@ (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