* Functional record "setters", a different approach
@ 2012-04-11 6:59 Mark H Weaver
2012-04-11 7:57 ` Mark H Weaver
` (2 more replies)
0 siblings, 3 replies; 22+ messages in thread
From: Mark H Weaver @ 2012-04-11 6:59 UTC (permalink / raw)
To: guile-devel
[-- Attachment #1: Type: text/plain, Size: 4992 bytes --]
Hello all,
Attached below is my preliminary attempt at functional record "setters".
These macros generate optimal code to generate a modified copy of an
existing tree of srfi-9 records, with any number of elements modified at
once.
I confess that this task was more difficult than I had anticipated, and
it required a different approach than Ludovic had taken, because
functional single-field-setters cannot be used to build an optimal
functional multi-field-setter.
Instead, each record type defines a '%%<TYPE-NAME>-modified-copy' macro
that copies a record but with an arbitrary number of modified fields.
This is the basis for the exported macros 'modified-copy' and
'modified-copy-nocheck' that supports arbitrarily nested records.
As Ludovic warned, this requires knowledge of the record types at
expansion time. To accomplish this, I enhanced srfi-9's private
'define-inlinable' macro to allow an arbitrary number of key/value pairs
to be associated with the generated macro. The new macro is called
'define-tagged-inlinable', and it's used like this:
(define-tagged-inlinable (key value) ... (name formals ...) body ...)
where each 'key' is a private literal identifier in (srfi srfi-9).
Currently, the keys '%%type', '%%index', and '%%copier' are associated
with each getter, which causes the getter macro to support additional
rules:
(<GETTER> () %%copier) ==> %%<TYPE-NAME>-modified-copy
(<GETTER> () %%type) ==> %%<TYPE-NAME>
(<GETTER> () %%index) ==> <INTEGER>
Since the keys are private to (srfi srfi-9), users cannot use these
private rules without accessing srfi-9's private symbols.
While I was at it, I incorporated Andy's suggestions
(accessors/modifiers => getters/setters, throw-bad-struct), and made
various other simplifications and improvements to the existing srfi-9
code, while being careful to remain ABI compatible with .go files
compiled with earlier versions of Guile 2.
Anyway, enough about the internals.
The public interface I've created is quite a bit different than what
we've been discussing so far. I'm open to changing it, but here's what
the attached patch currently exports from (srfi srfi-9 gnu):
(modified-copy <struct-expr> (<field-path> <expr>) ...)
(modified-copy-nocheck <struct-expr> (<field-path> <expr>) ...)
where <field-path> is of the form (<field> ...)
These macros can be used on _any_ srfi-9 record, not just ones specially
declared as immutable. In fact, I have not yet gotten around to
creating immutable records (with "pr" layout), though I would like to
add this soon. However, I see no reason not to support 'modified-copy'
on mutable records as well.
Here's an example session:
scheme@(guile-user)> ,use (srfi srfi-9)
scheme@(guile-user)> ,use (srfi srfi-9 gnu)
scheme@(guile-user)> (define-record-type :foo
(make-foo x)
foo?
(x get-x)
(y get-y set-y!))
scheme@(guile-user)> (define-record-type :bar
(make-bar i j)
bar?
(i get-i)
(j get-j set-j!))
scheme@(guile-user)> (define a (make-foo (make-bar 1 (make-foo 2))))
scheme@(guile-user)> a
$1 = #<:foo x: #<:bar i: 1 j: #<:foo x: 2 y: #f>> y: #f>
scheme@(guile-user)> (modified-copy a
((get-x get-i) 10)
((get-y) 14)
((get-x get-j get-y) 12))
$2 = #<:foo x: #<:bar i: 10 j: #<:foo x: 2 y: 12>> y: 14>
scheme@(guile-user)> ,opt (modified-copy-nocheck a
((get-x get-i) 10)
((get-y) 14)
((get-x get-j get-y) 12))
$3 = (let ((s a))
(make-struct/no-tail
:foo
(let ((s (struct-ref s 0)))
(make-struct/no-tail
:bar
10
(let ((s (struct-ref s 1)))
(make-struct/no-tail :foo (struct-ref s 0) 12))))
14))
scheme@(guile-user)> ,opt (modified-copy a
((get-x get-i) 10)
((get-y) 14)
((get-x get-j get-y) 12))
$4 = (let ((s a))
(if (eq? (struct-vtable s) :foo)
(make-struct/no-tail
:foo
(let ((s (struct-ref s 0)))
(if (eq? (struct-vtable s) :bar)
(make-struct/no-tail
:bar
10
(let ((s (struct-ref s 1)))
(if (eq? (struct-vtable s) :foo)
(make-struct/no-tail :foo (struct-ref s 0) 12)
((@@ (srfi srfi-9) throw-bad-struct)
s
'%%:foo-modified-copy))))
((@@ (srfi srfi-9) throw-bad-struct)
s
'%%:bar-modified-copy)))
14)
((@@ (srfi srfi-9) throw-bad-struct)
s
'%%:foo-modified-copy)))
scheme@(guile-user)>
Comments and suggestions solicited.
Mark
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Mark's preliminary functional setters patch v1 --]
[-- Type: text/x-patch, Size: 13083 bytes --]
diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm
index 4b36ce3..866d28b 100644
--- a/module/srfi/srfi-9.scm
+++ b/module/srfi/srfi-9.scm
@@ -60,7 +60,7 @@
(define-module (srfi srfi-9)
#:use-module (srfi srfi-1)
- #:export (define-record-type))
+ #:export-syntax (define-record-type))
(cond-expand-provide (current-module) '(srfi-9))
@@ -68,8 +68,26 @@
;; because the public one has a different `make-procedure-name', so
;; using it would require users to recompile code that uses SRFI-9. See
;; <http://lists.gnu.org/archive/html/guile-devel/2011-04/msg00111.html>.
+;;
+
+(define-syntax-rule (define-inlinable (name formals ...) body ...)
+ (define-tagged-inlinable () (name formals ...) body ...))
+
+;; 'define-tagged-inlinable' has an additional feature: it stores a map
+;; of keys to values that can be retrieved at expansion time. This is
+;; currently used to retrieve the rtd id, field index, and record copier
+;; macro for an arbitrary getter.
+
+(define %%type #f) ; a private syntax literal
+(define-syntax-rule (getter-type getter) (getter () %%type))
-(define-syntax define-inlinable
+(define %%index #f) ; a private syntax literal
+(define-syntax-rule (getter-index getter) (getter () %%index))
+
+(define %%copier #f) ; a private syntax literal
+(define-syntax-rule (getter-copier getter) (getter () %%copier))
+
+(define-syntax define-tagged-inlinable
(lambda (x)
(define (make-procedure-name name)
(datum->syntax name
@@ -77,7 +95,7 @@
'-procedure)))
(syntax-case x ()
- ((_ (name formals ...) body ...)
+ ((_ ((key value) ...) (name formals ...) body ...)
(identifier? #'name)
(with-syntax ((proc-name (make-procedure-name #'name))
((args ...) (generate-temporaries #'(formals ...))))
@@ -86,7 +104,8 @@
body ...)
(define-syntax name
(lambda (x)
- (syntax-case x ()
+ (syntax-case x (key ...)
+ ((_ () key) #'value) ...
((_ args ...)
#'((lambda (formals ...)
body ...)
@@ -114,6 +133,49 @@
"Wrong type argument: ~S" (list s)
(list s)))
+(define (make-copier-id type-name)
+ (datum->syntax type-name
+ (symbol-append '%% (syntax->datum type-name)
+ '-modified-copy)))
+
+(define-syntax %%modified-copy
+ (lambda (x)
+ (syntax-case x ()
+ ((_ type-name (getter-id ...) check? s (getter expr) ...)
+ (every identifier? #'(getter ...))
+ (let ((copier-name (syntax->datum (make-copier-id #'type-name)))
+ (getter+exprs #'((getter expr) ...)))
+ (define (lookup id default-expr)
+ (let ((results
+ (filter (lambda (g+e)
+ (free-identifier=? id (car g+e)))
+ getter+exprs)))
+ (case (length results)
+ ((0) default-expr)
+ ((1) (cadar results))
+ (else (syntax-violation
+ copier-name "duplicate getter" x id)))))
+ (for-each (lambda (id)
+ (or (find (lambda (getter-id)
+ (free-identifier=? id getter-id))
+ #'(getter-id ...))
+ (syntax-violation
+ copier-name "unknown getter" x id)))
+ #'(getter ...))
+ (with-syntax ((unsafe-expr
+ #`(make-struct
+ type-name 0
+ #,@(map (lambda (getter index)
+ (lookup getter #`(struct-ref s #,index)))
+ #'(getter-id ...)
+ (iota (length #'(getter-id ...)))))))
+ (if (syntax->datum #'check?)
+ #`(if (eq? (struct-vtable s) type-name)
+ unsafe-expr
+ (throw-bad-struct
+ s '#,(datum->syntax #'here copier-name)))
+ #'unsafe-expr)))))))
+
(define-syntax define-record-type
(lambda (x)
(define (field-identifiers field-specs)
@@ -123,29 +185,57 @@
((name getter setter) #'name)))
field-specs))
- (define (constructor type-name constructor-spec field-names)
+ (define (getter-identifiers field-specs)
+ (map (lambda (field-spec)
+ (syntax-case field-spec ()
+ ((name getter) #'getter)
+ ((name getter setter) #'getter)))
+ field-specs))
+
+ (define (constructor form type-name constructor-spec field-names)
(syntax-case constructor-spec ()
((ctor field ...)
- (let ((field-count (length field-names))
- (ctor-args (map (lambda (field)
- (cons (syntax->datum field) field))
- #'(field ...))))
+ (every identifier? #'(field ...))
+ (let ((ctor-args (map (lambda (field)
+ (let ((name (syntax->datum field)))
+ (or (memq name field-names)
+ (syntax-violation
+ 'define-record-type
+ "unknown field in constructor-spec"
+ form field))
+ (cons name field)))
+ #'(field ...))))
#`(define-inlinable #,constructor-spec
(make-struct #,type-name 0
#,@(map (lambda (name)
(assq-ref ctor-args name))
field-names)))))))
- (define (getters type-name field-specs)
- (map (lambda (field-spec index)
- (syntax-case field-spec ()
- ((name getter . _)
- #`(define-inlinable (getter s)
- (if (eq? (struct-vtable s) #,type-name)
- (struct-ref s #,index)
- (throw-bad-struct s 'getter))))))
- field-specs
- (iota (length field-specs))))
+ (define (copier type-name getter-ids copier-id)
+ (with-syntax ((type-name type-name)
+ (getter-ids getter-ids)
+ ;; FIXME: Using 'copier-id' here (without stripping
+ ;; its wrap) fails when 'define-record-type' is used
+ ;; at non-top-level. Why?
+ (copier-id (datum->syntax
+ #'here (syntax->datum copier-id))))
+ #'(define-syntax-rule
+ (copier-id check? s (getter expr) (... ...))
+ (%%modified-copy type-name getter-ids
+ check? s (getter expr) (... ...)))))
+
+ (define (getters type-name getter-ids copier-id)
+ (map (lambda (getter index)
+ #`(define-tagged-inlinable
+ ((%%type #,type-name)
+ (%%index #,index)
+ (%%copier #,copier-id))
+ (#,getter s)
+ (if (eq? (struct-vtable s) #,type-name)
+ (struct-ref s #,index)
+ (throw-bad-struct s '#,getter))))
+ getter-ids
+ (iota (length getter-ids))))
(define (setters type-name field-specs)
(filter-map (lambda (field-spec index)
@@ -161,14 +251,16 @@
(syntax-case x ()
((_ type-name constructor-spec predicate-name field-spec ...)
- (let* ((fields (field-identifiers #'(field-spec ...)))
- (field-count (length fields))
+ (let* ((field-ids (field-identifiers #'(field-spec ...)))
+ (getter-ids (getter-identifiers #'(field-spec ...)))
+ (field-count (length field-ids))
(layout (string-concatenate (make-list field-count "pw")))
- (field-names (map syntax->datum fields))
+ (field-names (map syntax->datum field-ids))
(ctor-name (syntax-case #'constructor-spec ()
- ((ctor args ...) #'ctor))))
+ ((ctor args ...) #'ctor)))
+ (copier-id (make-copier-id #'type-name)))
#`(begin
- #,(constructor #'type-name #'constructor-spec field-names)
+ #,(constructor x #'type-name #'constructor-spec field-names)
(define type-name
(let ((rtd (make-struct/no-tail
@@ -176,7 +268,7 @@
'#,(datum->syntax #'here (make-struct-layout layout))
default-record-printer
'type-name
- '#,fields)))
+ '#,field-ids)))
(set-struct-vtable-name! rtd 'type-name)
(struct-set! rtd (+ 2 vtable-offset-user) #,ctor-name)
rtd))
@@ -185,7 +277,9 @@
(and (struct? obj)
(eq? (struct-vtable obj) type-name)))
- #,@(getters #'type-name #'(field-spec ...))
- #,@(setters #'type-name #'(field-spec ...))))))))
+ #,@(getters #'type-name getter-ids copier-id)
+ #,@(setters #'type-name #'(field-spec ...))
+ #,(copier #'type-name getter-ids copier-id)
+ ))))))
;;; srfi-9.scm ends here
diff --git a/module/srfi/srfi-9/gnu.scm b/module/srfi/srfi-9/gnu.scm
index 30c101b..d9c24a1 100644
--- a/module/srfi/srfi-9/gnu.scm
+++ b/module/srfi/srfi-9/gnu.scm
@@ -1,6 +1,6 @@
;;; Extensions to SRFI-9
-;; Copyright (C) 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2012 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@@ -23,8 +23,63 @@
;;; Code:
(define-module (srfi srfi-9 gnu)
- #:export (set-record-type-printer!))
+ #:use-module (srfi srfi-1)
+ #:export (set-record-type-printer!)
+ #:export-syntax (modified-copy modified-copy-nocheck))
(define (set-record-type-printer! type thunk)
"Set a custom printer THUNK for TYPE."
(struct-set! type vtable-index-printer thunk))
+
+(define-syntax-rule (modified-copy s . rest)
+ (%modified-copy #t s . rest))
+
+(define-syntax-rule (modified-copy-nocheck s . rest)
+ (%modified-copy #f s . rest))
+
+(define-syntax %modified-copy
+ (lambda (x)
+ (with-syntax ((getter-type #'(@@ (srfi srfi-9) getter-type))
+ (getter-index #'(@@ (srfi srfi-9) getter-index))
+ (getter-copier #'(@@ (srfi srfi-9) getter-copier)))
+ (syntax-case x ()
+ ((_ check? s)
+ #'s)
+ ((_ check? s (() e))
+ #'e)
+ ((_ check? struct-expr ((getter . rest) expr) ...)
+ ;;
+ ;; FIXME: Improve compile-time error reporting:
+ ;; 1. report an error if any getter-path is a
+ ;; prefix of any other getter-path.
+ ;; 2. report an error if the initial getters
+ ;; do not all belong to the same record type.
+ ;;
+ ;; forest : (tree ...)
+ ;; tree : (getter (rest . expr) ...)
+ (let ((forest
+ (fold (lambda (g r e forest)
+ (cond ((find (lambda (tree)
+ (free-identifier=? g (car tree)))
+ forest)
+ => (lambda (tree)
+ (cons (cons g (cons (cons r e)
+ (cdr tree)))
+ (delq tree forest))))
+ (else (cons (list g (cons r e))
+ forest))))
+ '()
+ #'(getter ...)
+ #'(rest ...)
+ #'(expr ...))))
+ #`(let ((s struct-expr))
+ ((getter-copier #,(caar forest))
+ check?
+ s
+ #,@(map (lambda (tree)
+ (with-syntax (((getter (rest . expr) ...) tree))
+ #'(getter (%modified-copy
+ check?
+ (struct-ref s (getter-index getter))
+ (rest expr) ...))))
+ forest)))))))))
diff --git a/test-suite/tests/srfi-9.test b/test-suite/tests/srfi-9.test
index 321fe16..d0668db 100644
--- a/test-suite/tests/srfi-9.test
+++ b/test-suite/tests/srfi-9.test
@@ -29,7 +29,7 @@
(x get-x) (y get-y set-y!))
(define-record-type :bar (make-bar i j) bar?
- (i get-i) (i get-j set-j!))
+ (i get-i) (j get-j set-j!))
(define f (make-foo 1))
(set-y! f 2)
^ permalink raw reply related [flat|nested] 22+ messages in thread
* Re: Functional record "setters", a different approach
2012-04-11 6:59 Functional record "setters", a different approach Mark H Weaver
@ 2012-04-11 7:57 ` Mark H Weaver
2012-04-11 8:20 ` Mark H Weaver
2012-04-11 22:22 ` Ludovic Courtès
2012-11-07 20:04 ` Mark H Weaver
2 siblings, 1 reply; 22+ messages in thread
From: Mark H Weaver @ 2012-04-11 7:57 UTC (permalink / raw)
To: guile-devel
I rushed out my last email because I didn't want anyone else to waste
time working on the same functionality. Needless to say, this is very
preliminary work. A few errata in my last email:
> (define-tagged-inlinable (key value) ... (name formals ...) body ...)
There's a missing pair of parens around "(key value) ..." here.
> The public interface I've created is quite a bit different than what
> we've been discussing so far. I'm open to changing it, but here's what
> the attached patch currently exports from (srfi srfi-9 gnu):
>
> (modified-copy <struct-expr> (<field-path> <expr>) ...)
> (modified-copy-nocheck <struct-expr> (<field-path> <expr>) ...)
>
> where <field-path> is of the form (<field> ...)
The "path" is actually a list of getters, not field names.
> scheme@(guile-user)> (modified-copy a
> ((get-x get-i) 10)
> ((get-y) 14)
> ((get-x get-j get-y) 12))
Needless to say, I suck at marketing :) These record definitions are
what I used for testing (taken from srfi-9.test), but this syntax looks
very bad when the getters are named like this. It looks much better
when the getters have names like the ones Ludovic chose for his
examples, e.g. 'person-age', 'person-address', 'address-street',
'address-city', etc.
> --- a/test-suite/tests/srfi-9.test
> +++ b/test-suite/tests/srfi-9.test
> @@ -29,7 +29,7 @@
> (x get-x) (y get-y set-y!))
>
> (define-record-type :bar (make-bar i j) bar?
> - (i get-i) (i get-j set-j!))
> + (i get-i) (j get-j set-j!))
>
> (define f (make-foo 1))
> (set-y! f 2)
Note that I improved the compile-time error checking to the existing
srfi-9 macros, which called attention to the mistake in srfi-9.test
above. Previously, our srfi-9 implementation silently accepted
duplicate field names.
Mark
^ permalink raw reply [flat|nested] 22+ messages in thread
* Re: Functional record "setters", a different approach
2012-04-11 7:57 ` Mark H Weaver
@ 2012-04-11 8:20 ` Mark H Weaver
2012-04-11 22:27 ` Ludovic Courtès
0 siblings, 1 reply; 22+ messages in thread
From: Mark H Weaver @ 2012-04-11 8:20 UTC (permalink / raw)
To: guile-devel
[-- Attachment #1: Type: text/plain, Size: 405 bytes --]
I wrote:
> I rushed out my last email because I didn't want anyone else to waste
> time working on the same functionality.
More importantly, I just realized that the patch I sent out included
only part of my changes. It was missing my initial work to clean up the
srfi-9 code before I started adding the new functionality. Here's the
complete patch. Apologies for the wasted bandwidth :-(
Mark
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Mark's preliminary functional setters patch v2 --]
[-- Type: text/x-patch, Size: 16348 bytes --]
diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm
index da71d1e..866d28b 100644
--- a/module/srfi/srfi-9.scm
+++ b/module/srfi/srfi-9.scm
@@ -29,8 +29,8 @@
;; <predicate name>
;; <field spec> ...)
;;
-;; <field spec> -> (<field tag> <accessor name>)
-;; -> (<field tag> <accessor name> <modifier name>)
+;; <field spec> -> (<field tag> <getter name>)
+;; -> (<field tag> <getter name> <setter name>)
;;
;; <field tag> -> <identifier>
;; <... name> -> <identifier>
@@ -60,7 +60,7 @@
(define-module (srfi srfi-9)
#:use-module (srfi srfi-1)
- #:export (define-record-type))
+ #:export-syntax (define-record-type))
(cond-expand-provide (current-module) '(srfi-9))
@@ -68,8 +68,26 @@
;; because the public one has a different `make-procedure-name', so
;; using it would require users to recompile code that uses SRFI-9. See
;; <http://lists.gnu.org/archive/html/guile-devel/2011-04/msg00111.html>.
+;;
+
+(define-syntax-rule (define-inlinable (name formals ...) body ...)
+ (define-tagged-inlinable () (name formals ...) body ...))
+
+;; 'define-tagged-inlinable' has an additional feature: it stores a map
+;; of keys to values that can be retrieved at expansion time. This is
+;; currently used to retrieve the rtd id, field index, and record copier
+;; macro for an arbitrary getter.
+
+(define %%type #f) ; a private syntax literal
+(define-syntax-rule (getter-type getter) (getter () %%type))
-(define-syntax define-inlinable
+(define %%index #f) ; a private syntax literal
+(define-syntax-rule (getter-index getter) (getter () %%index))
+
+(define %%copier #f) ; a private syntax literal
+(define-syntax-rule (getter-copier getter) (getter () %%copier))
+
+(define-syntax define-tagged-inlinable
(lambda (x)
(define (make-procedure-name name)
(datum->syntax name
@@ -77,7 +95,7 @@
'-procedure)))
(syntax-case x ()
- ((_ (name formals ...) body ...)
+ ((_ ((key value) ...) (name formals ...) body ...)
(identifier? #'name)
(with-syntax ((proc-name (make-procedure-name #'name))
((args ...) (generate-temporaries #'(formals ...))))
@@ -86,7 +104,8 @@
body ...)
(define-syntax name
(lambda (x)
- (syntax-case x ()
+ (syntax-case x (key ...)
+ ((_ () key) #'value) ...
((_ args ...)
#'((lambda (formals ...)
body ...)
@@ -109,90 +128,139 @@
(loop (cdr fields) (+ 1 off)))))
(display ">" p))
+(define (throw-bad-struct s who)
+ (throw 'wrong-type-arg who
+ "Wrong type argument: ~S" (list s)
+ (list s)))
+
+(define (make-copier-id type-name)
+ (datum->syntax type-name
+ (symbol-append '%% (syntax->datum type-name)
+ '-modified-copy)))
+
+(define-syntax %%modified-copy
+ (lambda (x)
+ (syntax-case x ()
+ ((_ type-name (getter-id ...) check? s (getter expr) ...)
+ (every identifier? #'(getter ...))
+ (let ((copier-name (syntax->datum (make-copier-id #'type-name)))
+ (getter+exprs #'((getter expr) ...)))
+ (define (lookup id default-expr)
+ (let ((results
+ (filter (lambda (g+e)
+ (free-identifier=? id (car g+e)))
+ getter+exprs)))
+ (case (length results)
+ ((0) default-expr)
+ ((1) (cadar results))
+ (else (syntax-violation
+ copier-name "duplicate getter" x id)))))
+ (for-each (lambda (id)
+ (or (find (lambda (getter-id)
+ (free-identifier=? id getter-id))
+ #'(getter-id ...))
+ (syntax-violation
+ copier-name "unknown getter" x id)))
+ #'(getter ...))
+ (with-syntax ((unsafe-expr
+ #`(make-struct
+ type-name 0
+ #,@(map (lambda (getter index)
+ (lookup getter #`(struct-ref s #,index)))
+ #'(getter-id ...)
+ (iota (length #'(getter-id ...)))))))
+ (if (syntax->datum #'check?)
+ #`(if (eq? (struct-vtable s) type-name)
+ unsafe-expr
+ (throw-bad-struct
+ s '#,(datum->syntax #'here copier-name)))
+ #'unsafe-expr)))))))
+
(define-syntax define-record-type
(lambda (x)
(define (field-identifiers field-specs)
- (syntax-case field-specs ()
- (()
- '())
- ((field-spec)
- (syntax-case #'field-spec ()
- ((name accessor) #'(name))
- ((name accessor modifier) #'(name))))
- ((field-spec rest ...)
- (append (field-identifiers #'(field-spec))
- (field-identifiers #'(rest ...))))))
-
- (define (field-indices fields)
- (fold (lambda (field result)
- (let ((i (if (null? result)
- 0
- (+ 1 (cdar result)))))
- (alist-cons field i result)))
- '()
- fields))
-
- (define (constructor type-name constructor-spec indices)
+ (map (lambda (field-spec)
+ (syntax-case field-spec ()
+ ((name getter) #'name)
+ ((name getter setter) #'name)))
+ field-specs))
+
+ (define (getter-identifiers field-specs)
+ (map (lambda (field-spec)
+ (syntax-case field-spec ()
+ ((name getter) #'getter)
+ ((name getter setter) #'getter)))
+ field-specs))
+
+ (define (constructor form type-name constructor-spec field-names)
(syntax-case constructor-spec ()
((ctor field ...)
- (let ((field-count (length indices))
- (ctor-args (map (lambda (field)
- (cons (syntax->datum field) field))
- #'(field ...))))
+ (every identifier? #'(field ...))
+ (let ((ctor-args (map (lambda (field)
+ (let ((name (syntax->datum field)))
+ (or (memq name field-names)
+ (syntax-violation
+ 'define-record-type
+ "unknown field in constructor-spec"
+ form field))
+ (cons name field)))
+ #'(field ...))))
#`(define-inlinable #,constructor-spec
(make-struct #,type-name 0
- #,@(unfold
- (lambda (field-num)
- (>= field-num field-count))
- (lambda (field-num)
- (let* ((name
- (car (find (lambda (f+i)
- (= (cdr f+i) field-num))
- indices)))
- (arg (assq name ctor-args)))
- (if (pair? arg)
- (cdr arg)
- #'#f)))
- 1+
- 0)))))))
-
- (define (accessors type-name field-specs indices)
- (syntax-case field-specs ()
- (()
- #'())
- ((field-spec)
- (syntax-case #'field-spec ()
- ((name accessor)
- (with-syntax ((index (assoc-ref indices (syntax->datum #'name))))
- #`((define-inlinable (accessor s)
- (if (eq? (struct-vtable s) #,type-name)
- (struct-ref s index)
- (throw 'wrong-type-arg 'accessor
- "Wrong type argument: ~S" (list s)
- (list s)))))))
- ((name accessor modifier)
- (with-syntax ((index (assoc-ref indices (syntax->datum #'name))))
- #`(#,@(accessors type-name #'((name accessor)) indices)
- (define-inlinable (modifier s val)
- (if (eq? (struct-vtable s) #,type-name)
- (struct-set! s index val)
- (throw 'wrong-type-arg 'modifier
- "Wrong type argument: ~S" (list s)
- (list s)))))))))
- ((field-spec rest ...)
- #`(#,@(accessors type-name #'(field-spec) indices)
- #,@(accessors type-name #'(rest ...) indices)))))
+ #,@(map (lambda (name)
+ (assq-ref ctor-args name))
+ field-names)))))))
+
+ (define (copier type-name getter-ids copier-id)
+ (with-syntax ((type-name type-name)
+ (getter-ids getter-ids)
+ ;; FIXME: Using 'copier-id' here (without stripping
+ ;; its wrap) fails when 'define-record-type' is used
+ ;; at non-top-level. Why?
+ (copier-id (datum->syntax
+ #'here (syntax->datum copier-id))))
+ #'(define-syntax-rule
+ (copier-id check? s (getter expr) (... ...))
+ (%%modified-copy type-name getter-ids
+ check? s (getter expr) (... ...)))))
+
+ (define (getters type-name getter-ids copier-id)
+ (map (lambda (getter index)
+ #`(define-tagged-inlinable
+ ((%%type #,type-name)
+ (%%index #,index)
+ (%%copier #,copier-id))
+ (#,getter s)
+ (if (eq? (struct-vtable s) #,type-name)
+ (struct-ref s #,index)
+ (throw-bad-struct s '#,getter))))
+ getter-ids
+ (iota (length getter-ids))))
+
+ (define (setters type-name field-specs)
+ (filter-map (lambda (field-spec index)
+ (syntax-case field-spec ()
+ ((name getter) #f)
+ ((name getter setter)
+ #`(define-inlinable (setter s val)
+ (if (eq? (struct-vtable s) #,type-name)
+ (struct-set! s #,index val)
+ (throw-bad-struct s 'setter))))))
+ field-specs
+ (iota (length field-specs))))
(syntax-case x ()
((_ type-name constructor-spec predicate-name field-spec ...)
- (let* ((fields (field-identifiers #'(field-spec ...)))
- (field-count (length fields))
+ (let* ((field-ids (field-identifiers #'(field-spec ...)))
+ (getter-ids (getter-identifiers #'(field-spec ...)))
+ (field-count (length field-ids))
(layout (string-concatenate (make-list field-count "pw")))
- (indices (field-indices (map syntax->datum fields)))
+ (field-names (map syntax->datum field-ids))
(ctor-name (syntax-case #'constructor-spec ()
- ((ctor args ...) #'ctor))))
+ ((ctor args ...) #'ctor)))
+ (copier-id (make-copier-id #'type-name)))
#`(begin
- #,(constructor #'type-name #'constructor-spec indices)
+ #,(constructor x #'type-name #'constructor-spec field-names)
(define type-name
(let ((rtd (make-struct/no-tail
@@ -200,7 +268,7 @@
'#,(datum->syntax #'here (make-struct-layout layout))
default-record-printer
'type-name
- '#,fields)))
+ '#,field-ids)))
(set-struct-vtable-name! rtd 'type-name)
(struct-set! rtd (+ 2 vtable-offset-user) #,ctor-name)
rtd))
@@ -209,6 +277,9 @@
(and (struct? obj)
(eq? (struct-vtable obj) type-name)))
- #,@(accessors #'type-name #'(field-spec ...) indices)))))))
+ #,@(getters #'type-name getter-ids copier-id)
+ #,@(setters #'type-name #'(field-spec ...))
+ #,(copier #'type-name getter-ids copier-id)
+ ))))))
;;; srfi-9.scm ends here
diff --git a/module/srfi/srfi-9/gnu.scm b/module/srfi/srfi-9/gnu.scm
index 30c101b..d9c24a1 100644
--- a/module/srfi/srfi-9/gnu.scm
+++ b/module/srfi/srfi-9/gnu.scm
@@ -1,6 +1,6 @@
;;; Extensions to SRFI-9
-;; Copyright (C) 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2012 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@@ -23,8 +23,63 @@
;;; Code:
(define-module (srfi srfi-9 gnu)
- #:export (set-record-type-printer!))
+ #:use-module (srfi srfi-1)
+ #:export (set-record-type-printer!)
+ #:export-syntax (modified-copy modified-copy-nocheck))
(define (set-record-type-printer! type thunk)
"Set a custom printer THUNK for TYPE."
(struct-set! type vtable-index-printer thunk))
+
+(define-syntax-rule (modified-copy s . rest)
+ (%modified-copy #t s . rest))
+
+(define-syntax-rule (modified-copy-nocheck s . rest)
+ (%modified-copy #f s . rest))
+
+(define-syntax %modified-copy
+ (lambda (x)
+ (with-syntax ((getter-type #'(@@ (srfi srfi-9) getter-type))
+ (getter-index #'(@@ (srfi srfi-9) getter-index))
+ (getter-copier #'(@@ (srfi srfi-9) getter-copier)))
+ (syntax-case x ()
+ ((_ check? s)
+ #'s)
+ ((_ check? s (() e))
+ #'e)
+ ((_ check? struct-expr ((getter . rest) expr) ...)
+ ;;
+ ;; FIXME: Improve compile-time error reporting:
+ ;; 1. report an error if any getter-path is a
+ ;; prefix of any other getter-path.
+ ;; 2. report an error if the initial getters
+ ;; do not all belong to the same record type.
+ ;;
+ ;; forest : (tree ...)
+ ;; tree : (getter (rest . expr) ...)
+ (let ((forest
+ (fold (lambda (g r e forest)
+ (cond ((find (lambda (tree)
+ (free-identifier=? g (car tree)))
+ forest)
+ => (lambda (tree)
+ (cons (cons g (cons (cons r e)
+ (cdr tree)))
+ (delq tree forest))))
+ (else (cons (list g (cons r e))
+ forest))))
+ '()
+ #'(getter ...)
+ #'(rest ...)
+ #'(expr ...))))
+ #`(let ((s struct-expr))
+ ((getter-copier #,(caar forest))
+ check?
+ s
+ #,@(map (lambda (tree)
+ (with-syntax (((getter (rest . expr) ...) tree))
+ #'(getter (%modified-copy
+ check?
+ (struct-ref s (getter-index getter))
+ (rest expr) ...))))
+ forest)))))))))
diff --git a/test-suite/tests/srfi-9.test b/test-suite/tests/srfi-9.test
index 321fe16..d0668db 100644
--- a/test-suite/tests/srfi-9.test
+++ b/test-suite/tests/srfi-9.test
@@ -29,7 +29,7 @@
(x get-x) (y get-y set-y!))
(define-record-type :bar (make-bar i j) bar?
- (i get-i) (i get-j set-j!))
+ (i get-i) (j get-j set-j!))
(define f (make-foo 1))
(set-y! f 2)
^ permalink raw reply related [flat|nested] 22+ messages in thread
* Re: Functional record "setters", a different approach
2012-04-11 6:59 Functional record "setters", a different approach Mark H Weaver
2012-04-11 7:57 ` Mark H Weaver
@ 2012-04-11 22:22 ` Ludovic Courtès
2012-04-12 15:04 ` Mark H Weaver
2012-11-07 20:04 ` Mark H Weaver
2 siblings, 1 reply; 22+ messages in thread
From: Ludovic Courtès @ 2012-04-11 22:22 UTC (permalink / raw)
To: guile-devel
Hi Mark,
Mark H Weaver <mhw@netris.org> skribis:
> I confess that this task was more difficult than I had anticipated, and
> it required a different approach than Ludovic had taken, because
> functional single-field-setters cannot be used to build an optimal
> functional multi-field-setter.
Heh, indeed, I was just looking into it.
> As Ludovic warned, this requires knowledge of the record types at
> expansion time. To accomplish this, I enhanced srfi-9's private
> 'define-inlinable' macro to allow an arbitrary number of key/value pairs
> to be associated with the generated macro. The new macro is called
> 'define-tagged-inlinable', and it's used like this:
>
> (define-tagged-inlinable (key value) ... (name formals ...) body ...)
>
> where each 'key' is a private literal identifier in (srfi srfi-9).
> Currently, the keys '%%type', '%%index', and '%%copier' are associated
> with each getter, which causes the getter macro to support additional
> rules:
>
> (<GETTER> () %%copier) ==> %%<TYPE-NAME>-modified-copy
> (<GETTER> () %%type) ==> %%<TYPE-NAME>
> (<GETTER> () %%index) ==> <INTEGER>
Looks like a nice generalization of the idea.
> Since the keys are private to (srfi srfi-9), users cannot use these
> private rules without accessing srfi-9's private symbols.
>
> While I was at it, I incorporated Andy's suggestions
> (accessors/modifiers => getters/setters, throw-bad-struct),
Me too. :-)
> The public interface I've created is quite a bit different than what
> we've been discussing so far. I'm open to changing it, but here's what
> the attached patch currently exports from (srfi srfi-9 gnu):
>
> (modified-copy <struct-expr> (<field-path> <expr>) ...)
> (modified-copy-nocheck <struct-expr> (<field-path> <expr>) ...)
>
> where <field-path> is of the form (<field> ...)
I’d still want named single-field setters, for convenience. For that,
we probably still need a separate ‘define-immutable-record-type’.
Also, I’d want to avoid the term ‘copy’, which is sounds low-level;
‘set’ seems more appropriate to me. WDYT?
Regarding the interface for multi-field nested changes, I’d still
prefer:
(set-field p (foo bar) val
(foo baz) chbouib)
Or is it less readable than:
(set-field p ((foo bar) val)
((foo baz) chbouib))
?
Finally, I think there’s shouldn’t be a ‘-nocheck’ version. Dynamic
typing entails run-time type checking, that’s a fact of life, but safety
shouldn’t have to be traded for performance.
> These macros can be used on _any_ srfi-9 record, not just ones specially
> declared as immutable.
I assume this preserves “ABI” compatibility too, right?
> Comments and suggestions solicited.
Modulo the above comments, this looks very cool!
What would you think of these changes?
However, in the future, could you please reply in the same thread, and
more importantly coordinate so we don’t waste time working on the same
code in parallel.
Thanks,
Ludo’.
^ permalink raw reply [flat|nested] 22+ messages in thread
* Re: Functional record "setters", a different approach
2012-04-11 8:20 ` Mark H Weaver
@ 2012-04-11 22:27 ` Ludovic Courtès
0 siblings, 0 replies; 22+ messages in thread
From: Ludovic Courtès @ 2012-04-11 22:27 UTC (permalink / raw)
To: guile-devel
Mark H Weaver <mhw@netris.org> skribis:
> + ((_ check? struct-expr ((getter . rest) expr) ...)
> + ;;
> + ;; FIXME: Improve compile-time error reporting:
> + ;; 1. report an error if any getter-path is a
> + ;; prefix of any other getter-path.
> + ;; 2. report an error if the initial getters
> + ;; do not all belong to the same record type.
> + ;;
> + ;; forest : (tree ...)
> + ;; tree : (getter (rest . expr) ...)
> + (let ((forest
> + (fold (lambda (g r e forest)
> + (cond ((find (lambda (tree)
> + (free-identifier=? g (car tree)))
> + forest)
> + => (lambda (tree)
> + (cons (cons g (cons (cons r e)
> + (cdr tree)))
> + (delq tree forest))))
> + (else (cons (list g (cons r e))
> + forest))))
> + '()
> + #'(getter ...)
> + #'(rest ...)
> + #'(expr ...))))
BTW this will need some more comments ;-), and perhaps splitting in
several functions for clarity. Using SRFI-1 alists and ‘match’ may help
as well. WDYT?
(I often find myself avoiding occurrences of ‘car’, ‘cdr’ & co. in my
code these days.)
FWIW I was using this approach to represent the tree of accessors:
(define (field-tree fields)
;; Given FIELDS, a list of field-accessor-lists, return a tree
;; that groups together FIELDS by prefix. Example:
;; FIELDS: ((f1 f2 f3) (f1 f4))
;; RESULT: ((f1 (f2 (f3)) (f4)))
(define (insert obj tree)
(match obj
((head tail ...)
(let ((sub (or (assoc-ref tree head) '())))
(cons (cons head (insert tail sub))
(alist-delete head tree))))
(()
tree)))
(fold-right insert '() fields))
Thanks,
Ludo’.
^ permalink raw reply [flat|nested] 22+ messages in thread
* Re: Functional record "setters", a different approach
2012-04-11 22:22 ` Ludovic Courtès
@ 2012-04-12 15:04 ` Mark H Weaver
2012-04-12 16:45 ` Thien-Thi Nguyen
2012-04-12 19:58 ` Ludovic Courtès
0 siblings, 2 replies; 22+ messages in thread
From: Mark H Weaver @ 2012-04-12 15:04 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: guile-devel
Hi Ludovic!
ludo@gnu.org (Ludovic Courtès) writes:
> Mark H Weaver <mhw@netris.org> skribis:
>> The public interface I've created is quite a bit different than what
>> we've been discussing so far. I'm open to changing it, but here's what
>> the attached patch currently exports from (srfi srfi-9 gnu):
>>
>> (modified-copy <struct-expr> (<field-path> <expr>) ...)
>> (modified-copy-nocheck <struct-expr> (<field-path> <expr>) ...)
>>
>> where <field-path> is of the form (<field> ...)
>
> I’d still want named single-field setters, for convenience. For that,
> we probably still need a separate ‘define-immutable-record-type’.
Agreed.
> Also, I’d want to avoid the term ‘copy’, which is sounds low-level;
> ‘set’ seems more appropriate to me. WDYT?
I agree that 'copy' is not a good term to use here, especially since no
copy is made in the zero-modification case of (modified-copy s).
However, I find the term 'set' misleading, since no mutation is taking
place. Maybe 'update'? I dunno, I don't have strong feelings on this.
> Regarding the interface for multi-field nested changes, I’d still
> prefer:
>
> (set-field p (foo bar) val
> (foo baz) chbouib)
>
> Or is it less readable than:
>
> (set-field p ((foo bar) val)
> ((foo baz) chbouib))
I find the first variant to be very un-scheme-like. One could make the
same argument about 'let', 'let-values', or 'cond', but the Scheme
community has consistently chosen the latter style of syntax. The
latter style allows better extensibility. Also, the 'syntax-rules'
pattern matching machinery works very nicely with the usual scheme
syntax, and poorly for your proposed syntax. I feel fairly strongly
about this.
> Finally, I think there’s shouldn’t be a ‘-nocheck’ version. Dynamic
> typing entails run-time type checking, that’s a fact of life, but safety
> shouldn’t have to be traded for performance.
Hmm. I agree that the 'nocheck' variant should not be prominently
mentioned, and perhaps not documented at all, but I suspect it will
prove useful to keep it around, even if only for our own internal use to
build efficient higher-level constructs.
For example, when I built this 'modified-copy' machinery, I was unable
to build upon the usual (<getter> s) syntax, because that would cause
the generated code to include many redundant checks (one for each field
retrieved).
For example, for (modified-copy s ((foo-x) 'new)) where 's' contains 10
fields, the expanded code would include 9 separate checks that 's' is
the right type. Even when our compiler becomes smart enough to
eliminate those redundant checks, it creates a lot of extra work for the
compiler, slowing everything down, and of course when interpreting (or
compiling without optimization) it is a serious lose.
Therefore, I needed a 'nocheck' version of the individual getters, so
that I could check the type just once and then fetch each individual
field without additional checks. Unfortunately, there was none, so I
needed I hack around this limitation, adding a mechanism to retrieve the
field-index from a getter at expansion time, and then using 'struct-ref'
directly. This is ugly. I'd have preferred to have a 'nocheck' getter
instead.
In summary, my view is that in order to enable practical elegant
programming for users, we sometimes need to do less elegant (or even
downright ugly) things in the lower levels. Otherwise the system will
be too slow, and users will reject elegant constructs such as functional
setters and just use plain mutation instead.
>> These macros can be used on _any_ srfi-9 record, not just ones specially
>> declared as immutable.
>
> I assume this preserves “ABI” compatibility too, right?
Yes.
> However, in the future, could you please reply in the same thread,
You're right, I should have done so.
> and more importantly coordinate so we don’t waste time working on the
> same code in parallel.
I started this work after you were (probably) asleep, and rushed to post
about it before you woke up, so I did my best there. If you would
prefer to use your own code instead, that's okay with me. As long as we
end up with a functional-multi-setter that generates good code, I'll be
satisfied.
> FWIW I was using this approach to represent the tree of accessors:
>
> (define (field-tree fields)
> ;; Given FIELDS, a list of field-accessor-lists, return a tree
> ;; that groups together FIELDS by prefix. Example:
> ;; FIELDS: ((f1 f2 f3) (f1 f4))
> ;; RESULT: ((f1 (f2 (f3)) (f4)))
> (define (insert obj tree)
> (match obj
> ((head tail ...)
> (let ((sub (or (assoc-ref tree head) '())))
> (cons (cons head (insert tail sub))
> (alist-delete head tree))))
> (()
> tree)))
>
> (fold-right insert '() fields))
I agree that this is much nicer than my corresponding code. Thanks for
sharing. Would you like me to incorporate something like this into my
code, or would you like to start with your code and maybe cherry-pick
ideas/code from mine? Either way is fine with me.
Thanks!
Mark
^ permalink raw reply [flat|nested] 22+ messages in thread
* Re: Functional record "setters", a different approach
2012-04-12 15:04 ` Mark H Weaver
@ 2012-04-12 16:45 ` Thien-Thi Nguyen
2012-04-12 19:58 ` Ludovic Courtès
1 sibling, 0 replies; 22+ messages in thread
From: Thien-Thi Nguyen @ 2012-04-12 16:45 UTC (permalink / raw)
To: guile-devel
() Mark H Weaver <mhw@netris.org>
() Thu, 12 Apr 2012 11:04:13 -0400
However, I find the term 'set' misleading, since no mutation is
taking place. Maybe 'update'? I dunno, I don't have strong
feelings on this.
How about ‘overlay’ (or ‘over-set’ or ‘mask’) or ‘interpose’ or
‘insinuate’ or ‘twiddle’ or ‘frob’ or ‘actually’ or ‘imho’ or some
combination of the previous and prefix ‘w/’ (e.g., ‘w/ho’)?
^ permalink raw reply [flat|nested] 22+ messages in thread
* Re: Functional record "setters", a different approach
2012-04-12 15:04 ` Mark H Weaver
2012-04-12 16:45 ` Thien-Thi Nguyen
@ 2012-04-12 19:58 ` Ludovic Courtès
2012-04-13 1:58 ` Mark H Weaver
1 sibling, 1 reply; 22+ messages in thread
From: Ludovic Courtès @ 2012-04-12 19:58 UTC (permalink / raw)
To: Mark H Weaver; +Cc: guile-devel
Hi Mark!
Mark H Weaver <mhw@netris.org> skribis:
> ludo@gnu.org (Ludovic Courtès) writes:
>> Mark H Weaver <mhw@netris.org> skribis:
>>> The public interface I've created is quite a bit different than what
>>> we've been discussing so far. I'm open to changing it, but here's what
>>> the attached patch currently exports from (srfi srfi-9 gnu):
>>>
>>> (modified-copy <struct-expr> (<field-path> <expr>) ...)
>>> (modified-copy-nocheck <struct-expr> (<field-path> <expr>) ...)
>>>
>>> where <field-path> is of the form (<field> ...)
>>
>> I’d still want named single-field setters, for convenience. For that,
>> we probably still need a separate ‘define-immutable-record-type’.
>
> Agreed.
Cool! Could you integrate it somehow, along with the tests I provided?
>> Also, I’d want to avoid the term ‘copy’, which is sounds low-level;
>> ‘set’ seems more appropriate to me. WDYT?
>
> I agree that 'copy' is not a good term to use here, especially since no
> copy is made in the zero-modification case of (modified-copy s).
>
> However, I find the term 'set' misleading, since no mutation is taking
> place. Maybe 'update'? I dunno, I don't have strong feelings on this.
I don’t find ‘set’ misleading because there’s no exclamation mark, and
because it’s conceptually about setting a field’s value. WDYT?
>> Regarding the interface for multi-field nested changes, I’d still
>> prefer:
>>
>> (set-field p (foo bar) val
>> (foo baz) chbouib)
>>
>> Or is it less readable than:
>>
>> (set-field p ((foo bar) val)
>> ((foo baz) chbouib))
>
> I find the first variant to be very un-scheme-like.
Yes; in hindsight, I have the same feeling.
>> Finally, I think there’s shouldn’t be a ‘-nocheck’ version. Dynamic
>> typing entails run-time type checking, that’s a fact of life, but safety
>> shouldn’t have to be traded for performance.
>
> Hmm. I agree that the 'nocheck' variant should not be prominently
> mentioned, and perhaps not documented at all, but I suspect it will
> prove useful to keep it around, even if only for our own internal use to
> build efficient higher-level constructs.
>
> For example, when I built this 'modified-copy' machinery, I was unable
> to build upon the usual (<getter> s) syntax, because that would cause
> the generated code to include many redundant checks (one for each field
> retrieved).
Would these checks be alleviated by Andy’s work on peval “predicates”?
> For example, for (modified-copy s ((foo-x) 'new)) where 's' contains 10
> fields, the expanded code would include 9 separate checks that 's' is
> the right type.
Couldn’t ‘modified-copy’ be implemented differently so that there’s only
one check? That seems like the most obvious (not necessarily the
easiest) way to address the problem.
Every time ‘car’ is used, there’s a type-check that users cannot
eliminate. IMO, if it were to be eliminated, it should be via
orthogonal means, not via the API: for instance, when the compiler knows
the check would always pass at run-time, or with (declare (unsafe)), or
with ‘-DSCM_RECKLESS’. A ‘car-nocheck’ wouldn’t be convenient, would it?
:-)
[...]
>> and more importantly coordinate so we don’t waste time working on the
>> same code in parallel.
>
> I started this work after you were (probably) asleep,
When I don’t sleep, I also have a daytime work, and a family, among
other things, which is why I am not this responsive. Also, I was
assuming I was holding a mutex on this, so-to-speak. Lastly, I check
email less frequently when I have a hack on my mind. :-)
> and rushed to post about it before you woke up, so I did my best
> there. If you would prefer to use your own code instead, that's okay
> with me. As long as we end up with a functional-multi-setter that
> generates good code, I'll be satisfied.
Yeah, me too. So I’m happy we’re getting close to an even better
solution!
>> FWIW I was using this approach to represent the tree of accessors:
>>
>> (define (field-tree fields)
>> ;; Given FIELDS, a list of field-accessor-lists, return a tree
>> ;; that groups together FIELDS by prefix. Example:
>> ;; FIELDS: ((f1 f2 f3) (f1 f4))
>> ;; RESULT: ((f1 (f2 (f3)) (f4)))
>> (define (insert obj tree)
>> (match obj
>> ((head tail ...)
>> (let ((sub (or (assoc-ref tree head) '())))
>> (cons (cons head (insert tail sub))
>> (alist-delete head tree))))
>> (()
>> tree)))
>>
>> (fold-right insert '() fields))
>
> I agree that this is much nicer than my corresponding code. Thanks for
> sharing. Would you like me to incorporate something like this into my
> code, or would you like to start with your code and maybe cherry-pick
> ideas/code from mine? Either way is fine with me.
I’ll let you see whether/how you can borrow from this in your code, if
that’s fine with you.
Thanks,
Ludo’.
^ permalink raw reply [flat|nested] 22+ messages in thread
* Re: Functional record "setters", a different approach
2012-04-12 19:58 ` Ludovic Courtès
@ 2012-04-13 1:58 ` Mark H Weaver
2012-04-13 15:41 ` Ludovic Courtès
2012-05-07 16:34 ` Ludovic Courtès
0 siblings, 2 replies; 22+ messages in thread
From: Mark H Weaver @ 2012-04-13 1:58 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: guile-devel
Hi Ludovic!
ludo@gnu.org (Ludovic Courtès) writes:
> Mark H Weaver <mhw@netris.org> skribis:
>> ludo@gnu.org (Ludovic Courtès) writes:
>>> I’d still want named single-field setters, for convenience. For that,
>>> we probably still need a separate ‘define-immutable-record-type’.
>>
>> Agreed.
>
> Cool! Could you integrate it somehow, along with the tests I provided?
Will do.
>> However, I find the term 'set' misleading, since no mutation is taking
>> place. Maybe 'update'? I dunno, I don't have strong feelings on this.
>
> I don’t find ‘set’ misleading because there’s no exclamation mark, and
> because it’s conceptually about setting a field’s value. WDYT?
Okay, on second thought I'm inclined to agree. 'set' is a good choice.
However, there's a problem with the name 'set-field': because 'field' is
a noun here, it should be made plural when more than one field is being
set. We could avoid this grammatical problem by making 'field' an
adjective, as in 'field-set'. This would also be consistent with the
names 'vector-set!', 'struct-set!', 'bitvector-set!', etc.
Another option is 'record-set'.
What do you think?
>>> Finally, I think there’s shouldn’t be a ‘-nocheck’ version. Dynamic
>>> typing entails run-time type checking, that’s a fact of life, but safety
>>> shouldn’t have to be traded for performance.
>>
>> Hmm. I agree that the 'nocheck' variant should not be prominently
>> mentioned, and perhaps not documented at all, but I suspect it will
>> prove useful to keep it around, even if only for our own internal use to
>> build efficient higher-level constructs.
>>
>> For example, when I built this 'modified-copy' machinery, I was unable
>> to build upon the usual (<getter> s) syntax, because that would cause
>> the generated code to include many redundant checks (one for each field
>> retrieved).
>
> Would these checks be alleviated by Andy’s work on peval “predicates”?
Unfortunately, no. The 'vtable' field of a struct is a mutable field,
and in fact when a GOOPS class is redefined, the 'vtable' field of
instances are modified. This means that it is not safe for the compiler
to eliminate redundant calls to 'struct-vtable'.
>> For example, for (modified-copy s ((foo-x) 'new)) where 's' contains 10
>> fields, the expanded code would include 9 separate checks that 's' is
>> the right type.
>
> Couldn’t ‘modified-copy’ be implemented differently so that there’s only
> one check? That seems like the most obvious (not necessarily the
> easiest) way to address the problem.
Yes, and that's exactly what I did. However, I was only able to
accomplish this by essentially hacking up my own '<getter>-nocheck'.
If I had used the normal getters in the expansion of 'modified-copy',
then (modified-copy s ((foo-x) 'new)) would expand to:
(make-struct <foo> 0
(foo-q s) (foo-r s) (foo-s s) (foo-t s) (foo-u s)
(foo-v s) (foo-w s) 'new (foo-y s) (foo-z s))
and each of those getter uses would include a type-check in their
expansions. As you suggested, I instead wrap a single check around the
whole thing and then effectively use (foo-*-nocheck s) instead, by using
'struct-ref' directly.
This example is intended to convince you that 'nocheck' variants of
struct accessors are important as a base upon which to build efficient
higher-level constructs, at least for our own internal use.
> Every time ‘car’ is used, there’s a type-check that users cannot
> eliminate. IMO, if it were to be eliminated, it should be via
> orthogonal means, not via the API: for instance, when the compiler knows
> the check would always pass at run-time, or with (declare (unsafe)), or
> with ‘-DSCM_RECKLESS’. A ‘car-nocheck’ wouldn’t be convenient, would it?
> :-)
Agreed, but in that case, redundant type tags checks _can_ be optimized
out by a compiler, because those tags are not mutable. Unfortunately,
the struct vtable pointers _are_ mutable, and in fact are mutated in
practice, so the compiler cannot safely eliminate struct-vtable checks.
> I’ll let you see whether/how you can borrow from this in your code, if
> that’s fine with you.
Okay, will do.
Thanks!
Mark
^ permalink raw reply [flat|nested] 22+ messages in thread
* Re: Functional record "setters", a different approach
2012-04-13 1:58 ` Mark H Weaver
@ 2012-04-13 15:41 ` Ludovic Courtès
2012-04-13 17:26 ` Mark H Weaver
2012-05-07 16:34 ` Ludovic Courtès
1 sibling, 1 reply; 22+ messages in thread
From: Ludovic Courtès @ 2012-04-13 15:41 UTC (permalink / raw)
To: Mark H Weaver; +Cc: guile-devel
Hi Mark!
And Happy Friday, as our friend would say. :-)
Mark H Weaver <mhw@netris.org> skribis:
> ludo@gnu.org (Ludovic Courtès) writes:
>> Mark H Weaver <mhw@netris.org> skribis:
>>> ludo@gnu.org (Ludovic Courtès) writes:
>>>> I’d still want named single-field setters, for convenience. For that,
>>>> we probably still need a separate ‘define-immutable-record-type’.
>>>
>>> Agreed.
>>
>> Cool! Could you integrate it somehow, along with the tests I provided?
>
> Will do.
Thanks!
>>> However, I find the term 'set' misleading, since no mutation is taking
>>> place. Maybe 'update'? I dunno, I don't have strong feelings on this.
>>
>> I don’t find ‘set’ misleading because there’s no exclamation mark, and
>> because it’s conceptually about setting a field’s value. WDYT?
>
> Okay, on second thought I'm inclined to agree. 'set' is a good choice.
[...]
> What do you think?
I’d say ‘set-fields’, no?
(There are actually two common conventions: one is TYPE-METHOD, as in
‘vector-ref’, and another is VERB-NAME, as is ‘make-list’, ‘let-values’.
I tend to prefer the latter, but sometimes the former is more convenient
or clearer.)
[...]
>> Would these checks be alleviated by Andy’s work on peval “predicates”?
>
> Unfortunately, no. The 'vtable' field of a struct is a mutable field,
> and in fact when a GOOPS class is redefined, the 'vtable' field of
> instances are modified. This means that it is not safe for the compiler
> to eliminate redundant calls to 'struct-vtable'.
Oh, OK. That is eviiiil.
>>> For example, for (modified-copy s ((foo-x) 'new)) where 's' contains 10
>>> fields, the expanded code would include 9 separate checks that 's' is
>>> the right type.
>>
>> Couldn’t ‘modified-copy’ be implemented differently so that there’s only
>> one check? That seems like the most obvious (not necessarily the
>> easiest) way to address the problem.
>
> Yes, and that's exactly what I did. However, I was only able to
> accomplish this by essentially hacking up my own '<getter>-nocheck'.
>
> If I had used the normal getters in the expansion of 'modified-copy',
> then (modified-copy s ((foo-x) 'new)) would expand to:
>
> (make-struct <foo> 0
> (foo-q s) (foo-r s) (foo-s s) (foo-t s) (foo-u s)
> (foo-v s) (foo-w s) 'new (foo-y s) (foo-z s))
>
> and each of those getter uses would include a type-check in their
> expansions. As you suggested, I instead wrap a single check around the
> whole thing and then effectively use (foo-*-nocheck s) instead, by using
> 'struct-ref' directly.
>
> This example is intended to convince you that 'nocheck' variants of
> struct accessors are important as a base upon which to build efficient
> higher-level constructs, at least for our own internal use.
I view it as an important “implementation detail”, but not as an API to
be exposed publicly.
What about keeping it private until we find an actual use case where it
is required outside of (srfi srfi-9)?
Thanks!
Ludo’.
^ permalink raw reply [flat|nested] 22+ messages in thread
* Re: Functional record "setters", a different approach
2012-04-13 15:41 ` Ludovic Courtès
@ 2012-04-13 17:26 ` Mark H Weaver
0 siblings, 0 replies; 22+ messages in thread
From: Mark H Weaver @ 2012-04-13 17:26 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: guile-devel
Hi Ludovic!
ludo@gnu.org (Ludovic Courtès) writes:
> I’d say ‘set-fields’, no?
Okay, good enough.
>>> Would these checks be alleviated by Andy’s work on peval “predicates”?
>>
>> Unfortunately, no. The 'vtable' field of a struct is a mutable field,
>> and in fact when a GOOPS class is redefined, the 'vtable' field of
>> instances are modified. This means that it is not safe for the compiler
>> to eliminate redundant calls to 'struct-vtable'.
>
> Oh, OK. That is eviiiil.
It turns out that I had some misconceptions about this. Although it is
true that the first word of a struct cell is mutated, that's actually
not what 'struct-vtable' returns nowadays. Class redefinition involves
a rather complicated dance described here:
http://wingolog.org/archives/2009/11/09/class-redefinition-in-guile
So, the result of 'struct-vtable' does not change after all, at least
not for plain instances. (It's not yet clear to me whether the vtable
of a redefined class object itself can be changed).
Regardless, 'struct-vtable' checks usually involve comparison with the
value of a mutable top-level variable, and of course the compiler must
assume that mutable variables might change whenever unknown code is run
(e.g. when any top-level procedure is called).
>> This example is intended to convince you that 'nocheck' variants of
>> struct accessors are important as a base upon which to build efficient
>> higher-level constructs, at least for our own internal use.
>
> I view it as an important “implementation detail”, but not as an API to
> be exposed publicly.
>
> What about keeping it private until we find an actual use case where it
> is required outside of (srfi srfi-9)?
Okay, fair enough :)
Thanks,
Mark
^ permalink raw reply [flat|nested] 22+ messages in thread
* Re: Functional record "setters", a different approach
2012-04-13 1:58 ` Mark H Weaver
2012-04-13 15:41 ` Ludovic Courtès
@ 2012-05-07 16:34 ` Ludovic Courtès
2012-05-14 22:25 ` Mark H Weaver
1 sibling, 1 reply; 22+ messages in thread
From: Ludovic Courtès @ 2012-05-07 16:34 UTC (permalink / raw)
To: guile-devel
Hi Mark!
Mark H Weaver <mhw@netris.org> skribis:
> ludo@gnu.org (Ludovic Courtès) writes:
>> I’ll let you see whether/how you can borrow from this in your code, if
>> that’s fine with you.
>
> Okay, will do.
Any progress on this? ;-)
I’m happy to help with updating the docs, for instance, if you want.
Thanks,
Ludo’.
^ permalink raw reply [flat|nested] 22+ messages in thread
* Re: Functional record "setters", a different approach
2012-05-07 16:34 ` Ludovic Courtès
@ 2012-05-14 22:25 ` Mark H Weaver
2012-05-15 21:23 ` Ludovic Courtès
0 siblings, 1 reply; 22+ messages in thread
From: Mark H Weaver @ 2012-05-14 22:25 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: guile-devel
ludo@gnu.org (Ludovic Courtès) writes:
> Mark H Weaver <mhw@netris.org> skribis:
>> ludo@gnu.org (Ludovic Courtès) writes:
>
>>> I’ll let you see whether/how you can borrow from this in your code, if
>>> that’s fine with you.
>>
>> Okay, will do.
>
> Any progress on this? ;-)
I apologize for dropping on the ball on this. The primary concern I
have with my current approach is that 'define-tagged-inlinable' adds
several more huge bloated syntax-objects to the getter macros. Of
course, as usual, this bloat will never be used, but everyone must pay
for 'datum->syntax' whether they use it or not :-(
> I’m happy to help with updating the docs, for instance, if you want.
That would be very helpful, thanks!
Mark
^ permalink raw reply [flat|nested] 22+ messages in thread
* Re: Functional record "setters", a different approach
2012-05-14 22:25 ` Mark H Weaver
@ 2012-05-15 21:23 ` Ludovic Courtès
0 siblings, 0 replies; 22+ messages in thread
From: Ludovic Courtès @ 2012-05-15 21:23 UTC (permalink / raw)
To: Mark H Weaver; +Cc: guile-devel
Hi Mark,
Mark H Weaver <mhw@netris.org> skribis:
> ludo@gnu.org (Ludovic Courtès) writes:
>> Mark H Weaver <mhw@netris.org> skribis:
>>> ludo@gnu.org (Ludovic Courtès) writes:
>>
>>>> I’ll let you see whether/how you can borrow from this in your code, if
>>>> that’s fine with you.
>>>
>>> Okay, will do.
>>
>> Any progress on this? ;-)
>
> I apologize for dropping on the ball on this. The primary concern I
> have with my current approach is that 'define-tagged-inlinable' adds
> several more huge bloated syntax-objects to the getter macros. Of
> course, as usual, this bloat will never be used, but everyone must pay
> for 'datum->syntax' whether they use it or not :-(
Are you concerned about the size of ‘srfi-9.go’, or is there some other
issue at stake?
While I agree that bloating .go files is not satisfying, I would not
consider it a showstopper here.
I suppose the only way to use fewer syntax objects would be to use a
specialize variant of ‘define-tagged-inlinable’, no? That would make
the code less elegant.
>> I’m happy to help with updating the docs, for instance, if you want.
>
> That would be very helpful, thanks!
OK, I’ll do that when the code is checked in.
Thanks,
Ludo’.
^ permalink raw reply [flat|nested] 22+ messages in thread
* Re: Functional record "setters", a different approach
2012-04-11 6:59 Functional record "setters", a different approach Mark H Weaver
2012-04-11 7:57 ` Mark H Weaver
2012-04-11 22:22 ` Ludovic Courtès
@ 2012-11-07 20:04 ` Mark H Weaver
2012-11-08 5:15 ` Mark H Weaver
2 siblings, 1 reply; 22+ messages in thread
From: Mark H Weaver @ 2012-11-07 20:04 UTC (permalink / raw)
To: guile-devel
[-- Attachment #1: Type: text/plain, Size: 699 bytes --]
Hello all,
Apologies for the long delay on this, but I've finally produced an
improved implementation of functional record setters for stable-2.0.
It is fully compatible with the earlier API proposed by Ludovic in
<http://lists.gnu.org/archive/html/guile-devel/2012-04/msg00032.html>
(i.e. 'define-immutable-record-type' and 'set-field'), but also adds
'set-fields' for efficiently setting multiple fields at once (to
arbitrary depth). I also spent a lot of effort to produce good
compile-time error messages where possible.
See srfi-9.test for example usage.
The only thing missing is the documentation, which Ludovic kindly
offered to write.
Comments and suggestions solicited.
Mark
[-- Attachment #2: [PATCH] Implement functional record setters --]
[-- Type: text/x-diff, Size: 33796 bytes --]
From cb09314846faf62461d63b17e108a95d7cff18c4 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Wed, 7 Nov 2012 12:21:44 -0500
Subject: [PATCH] Implement functional record setters.
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Written in collaboration with Ludovic Courtès <ludo@gnu.org>
* module/srfi/srfi-9.scm: Internally, rename 'accessor' to 'getter'
and 'modifier' to 'setter'.
(define-tagged-inlinable, getter-type, getter-index, getter-copier,
%%on-error, %%set-fields): New macros.
(%define-record-type): New macro for creating both mutable and
immutable records, and containing a substantially rewritten version of
the code formerly in 'define-record-type'.
(define-record-type): Now just a wrapper for '%define-record-type'.
(throw-bad-struct, make-copier-id): New procedures.
* module/srfi/srfi-9/gnu.scm (define-immutable-record-type, set-field,
and set-fields): New exported macros.
(collate-set-field-specs): New procedure.
(%set-fields-unknown-getter, %set-fields): New macros.
* test-suite/tests/srfi-9.test: Add tests.
---
module/srfi/srfi-9.scm | 252 ++++++++++++++++++++----------
module/srfi/srfi-9/gnu.scm | 100 +++++++++++-
test-suite/tests/srfi-9.test | 348 ++++++++++++++++++++++++++++++++++++++----
3 files changed, 589 insertions(+), 111 deletions(-)
diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm
index da71d1e..1dd132a 100644
--- a/module/srfi/srfi-9.scm
+++ b/module/srfi/srfi-9.scm
@@ -29,8 +29,8 @@
;; <predicate name>
;; <field spec> ...)
;;
-;; <field spec> -> (<field tag> <accessor name>)
-;; -> (<field tag> <accessor name> <modifier name>)
+;; <field spec> -> (<field tag> <getter name>)
+;; -> (<field tag> <getter name> <setter name>)
;;
;; <field tag> -> <identifier>
;; <... name> -> <identifier>
@@ -68,8 +68,31 @@
;; because the public one has a different `make-procedure-name', so
;; using it would require users to recompile code that uses SRFI-9. See
;; <http://lists.gnu.org/archive/html/guile-devel/2011-04/msg00111.html>.
+;;
+
+(define-syntax-rule (define-inlinable (name formals ...) body ...)
+ (define-tagged-inlinable () (name formals ...) body ...))
+
+;; 'define-tagged-inlinable' has an additional feature: it stores a map
+;; of keys to values that can be retrieved at expansion time. This is
+;; currently used to retrieve the rtd id, field index, and record copier
+;; macro for an arbitrary getter.
+
+(define-syntax-rule (%%on-error err) err)
+
+(define %%type #f) ; a private syntax literal
+(define-syntax-rule (getter-type getter err)
+ (getter (%%on-error err) %%type))
-(define-syntax define-inlinable
+(define %%index #f) ; a private syntax literal
+(define-syntax-rule (getter-index getter err)
+ (getter (%%on-error err) %%index))
+
+(define %%copier #f) ; a private syntax literal
+(define-syntax-rule (getter-copier getter err)
+ (getter (%%on-error err) %%copier))
+
+(define-syntax define-tagged-inlinable
(lambda (x)
(define (make-procedure-name name)
(datum->syntax name
@@ -77,7 +100,7 @@
'-procedure)))
(syntax-case x ()
- ((_ (name formals ...) body ...)
+ ((_ ((key value) ...) (name formals ...) body ...)
(identifier? #'name)
(with-syntax ((proc-name (make-procedure-name #'name))
((args ...) (generate-temporaries #'(formals ...))))
@@ -86,7 +109,8 @@
body ...)
(define-syntax name
(lambda (x)
- (syntax-case x ()
+ (syntax-case x (%%on-error key ...)
+ ((_ (%%on-error err) key) #'value) ...
((_ args ...)
#'((lambda (formals ...)
body ...)
@@ -109,90 +133,149 @@
(loop (cdr fields) (+ 1 off)))))
(display ">" p))
-(define-syntax define-record-type
+(define (throw-bad-struct s who)
+ (throw 'wrong-type-arg who
+ "Wrong type argument: ~S" (list s)
+ (list s)))
+
+(define (make-copier-id type-name)
+ (datum->syntax type-name
+ (symbol-append '%% (syntax->datum type-name)
+ '-set-fields)))
+
+(define-syntax %%set-fields
+ (lambda (x)
+ (syntax-case x ()
+ ((_ type-name (getter-id ...) check? s (getter expr) ...)
+ (every identifier? #'(getter ...))
+ (let ((copier-name (syntax->datum (make-copier-id #'type-name)))
+ (getter+exprs #'((getter expr) ...)))
+ (define (lookup id default-expr)
+ (let ((results
+ (filter (lambda (g+e)
+ (free-identifier=? id (car g+e)))
+ getter+exprs)))
+ (case (length results)
+ ((0) default-expr)
+ ((1) (cadar results))
+ (else (syntax-violation
+ copier-name "duplicate getter" x id)))))
+ (for-each (lambda (id)
+ (or (find (lambda (getter-id)
+ (free-identifier=? id getter-id))
+ #'(getter-id ...))
+ (syntax-violation
+ copier-name "unknown getter" x id)))
+ #'(getter ...))
+ (with-syntax ((unsafe-expr
+ #`(make-struct
+ type-name 0
+ #,@(map (lambda (getter index)
+ (lookup getter #`(struct-ref s #,index)))
+ #'(getter-id ...)
+ (iota (length #'(getter-id ...)))))))
+ (if (syntax->datum #'check?)
+ #`(if (eq? (struct-vtable s) type-name)
+ unsafe-expr
+ (throw-bad-struct
+ s '#,(datum->syntax #'here copier-name)))
+ #'unsafe-expr)))))))
+
+(define-syntax %define-record-type
(lambda (x)
(define (field-identifiers field-specs)
- (syntax-case field-specs ()
- (()
- '())
- ((field-spec)
- (syntax-case #'field-spec ()
- ((name accessor) #'(name))
- ((name accessor modifier) #'(name))))
- ((field-spec rest ...)
- (append (field-identifiers #'(field-spec))
- (field-identifiers #'(rest ...))))))
-
- (define (field-indices fields)
- (fold (lambda (field result)
- (let ((i (if (null? result)
- 0
- (+ 1 (cdar result)))))
- (alist-cons field i result)))
- '()
- fields))
-
- (define (constructor type-name constructor-spec indices)
+ (map (lambda (field-spec)
+ (syntax-case field-spec ()
+ ((name getter) #'name)
+ ((name getter setter) #'name)))
+ field-specs))
+
+ (define (getter-identifiers field-specs)
+ (map (lambda (field-spec)
+ (syntax-case field-spec ()
+ ((name getter) #'getter)
+ ((name getter setter) #'getter)))
+ field-specs))
+
+ (define (constructor form type-name constructor-spec field-names)
(syntax-case constructor-spec ()
((ctor field ...)
- (let ((field-count (length indices))
- (ctor-args (map (lambda (field)
- (cons (syntax->datum field) field))
- #'(field ...))))
+ (every identifier? #'(field ...))
+ (let ((ctor-args (map (lambda (field)
+ (let ((name (syntax->datum field)))
+ (or (memq name field-names)
+ (syntax-violation
+ 'define-record-type
+ "unknown field in constructor-spec"
+ form field))
+ (cons name field)))
+ #'(field ...))))
#`(define-inlinable #,constructor-spec
(make-struct #,type-name 0
- #,@(unfold
- (lambda (field-num)
- (>= field-num field-count))
- (lambda (field-num)
- (let* ((name
- (car (find (lambda (f+i)
- (= (cdr f+i) field-num))
- indices)))
- (arg (assq name ctor-args)))
- (if (pair? arg)
- (cdr arg)
- #'#f)))
- 1+
- 0)))))))
-
- (define (accessors type-name field-specs indices)
- (syntax-case field-specs ()
- (()
- #'())
- ((field-spec)
- (syntax-case #'field-spec ()
- ((name accessor)
- (with-syntax ((index (assoc-ref indices (syntax->datum #'name))))
- #`((define-inlinable (accessor s)
- (if (eq? (struct-vtable s) #,type-name)
- (struct-ref s index)
- (throw 'wrong-type-arg 'accessor
- "Wrong type argument: ~S" (list s)
- (list s)))))))
- ((name accessor modifier)
- (with-syntax ((index (assoc-ref indices (syntax->datum #'name))))
- #`(#,@(accessors type-name #'((name accessor)) indices)
- (define-inlinable (modifier s val)
- (if (eq? (struct-vtable s) #,type-name)
- (struct-set! s index val)
- (throw 'wrong-type-arg 'modifier
- "Wrong type argument: ~S" (list s)
- (list s)))))))))
- ((field-spec rest ...)
- #`(#,@(accessors type-name #'(field-spec) indices)
- #,@(accessors type-name #'(rest ...) indices)))))
+ #,@(map (lambda (name)
+ (assq-ref ctor-args name))
+ field-names)))))))
+
+ (define (getters type-name getter-ids copier-id)
+ (map (lambda (getter index)
+ #`(define-tagged-inlinable
+ ((%%type #,type-name)
+ (%%index #,index)
+ (%%copier #,copier-id))
+ (#,getter s)
+ (if (eq? (struct-vtable s) #,type-name)
+ (struct-ref s #,index)
+ (throw-bad-struct s '#,getter))))
+ getter-ids
+ (iota (length getter-ids))))
+
+ (define (copier type-name getter-ids copier-id)
+ #`(define-syntax-rule
+ (#,copier-id check? s (getter expr) (... ...))
+ (%%set-fields #,type-name #,getter-ids
+ check? s (getter expr) (... ...))))
+
+ (define (setters type-name field-specs)
+ (filter-map (lambda (field-spec index)
+ (syntax-case field-spec ()
+ ((name getter) #f)
+ ((name getter setter)
+ #`(define-inlinable (setter s val)
+ (if (eq? (struct-vtable s) #,type-name)
+ (struct-set! s #,index val)
+ (throw-bad-struct s 'setter))))))
+ field-specs
+ (iota (length field-specs))))
+
+ (define (functional-setters copier-id field-specs)
+ (filter-map (lambda (field-spec index)
+ (syntax-case field-spec ()
+ ((name getter) #f)
+ ((name getter setter)
+ #`(define-inlinable (setter s val)
+ (#,copier-id #t s (getter val))))))
+ field-specs
+ (iota (length field-specs))))
+
+ (define (record-layout immutable? count)
+ (let ((desc (if immutable? "pr" "pw")))
+ (string-concatenate (make-list count desc))))
(syntax-case x ()
- ((_ type-name constructor-spec predicate-name field-spec ...)
- (let* ((fields (field-identifiers #'(field-spec ...)))
- (field-count (length fields))
- (layout (string-concatenate (make-list field-count "pw")))
- (indices (field-indices (map syntax->datum fields)))
+ ((_ immutable? type-name constructor-spec predicate-name
+ field-spec ...)
+ (boolean? (syntax->datum #'immutable?))
+ (let* ((field-ids (field-identifiers #'(field-spec ...)))
+ (getter-ids (getter-identifiers #'(field-spec ...)))
+ (field-count (length field-ids))
+ (immutable? (syntax->datum #'immutable?))
+ (layout (record-layout immutable? field-count))
+ (field-names (map syntax->datum field-ids))
(ctor-name (syntax-case #'constructor-spec ()
- ((ctor args ...) #'ctor))))
+ ((ctor args ...) #'ctor)))
+ (copier-id (make-copier-id #'type-name)))
#`(begin
- #,(constructor #'type-name #'constructor-spec indices)
+ #,(constructor x #'type-name #'constructor-spec field-names)
(define type-name
(let ((rtd (make-struct/no-tail
@@ -200,7 +283,7 @@
'#,(datum->syntax #'here (make-struct-layout layout))
default-record-printer
'type-name
- '#,fields)))
+ '#,field-ids)))
(set-struct-vtable-name! rtd 'type-name)
(struct-set! rtd (+ 2 vtable-offset-user) #,ctor-name)
rtd))
@@ -209,6 +292,13 @@
(and (struct? obj)
(eq? (struct-vtable obj) type-name)))
- #,@(accessors #'type-name #'(field-spec ...) indices)))))))
+ #,@(getters #'type-name getter-ids copier-id)
+ #,(copier #'type-name getter-ids copier-id)
+ #,@(if immutable?
+ (functional-setters copier-id #'(field-spec ...))
+ (setters #'type-name #'(field-spec ...)))))))))
+
+(define-syntax-rule (define-record-type name ctor pred fields ...)
+ (%define-record-type #f name ctor pred fields ...))
;;; srfi-9.scm ends here
diff --git a/module/srfi/srfi-9/gnu.scm b/module/srfi/srfi-9/gnu.scm
index 30c101b..fa091fe 100644
--- a/module/srfi/srfi-9/gnu.scm
+++ b/module/srfi/srfi-9/gnu.scm
@@ -1,6 +1,6 @@
;;; Extensions to SRFI-9
-;; Copyright (C) 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2012 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@@ -23,8 +23,104 @@
;;; Code:
(define-module (srfi srfi-9 gnu)
- #:export (set-record-type-printer!))
+ #:use-module (srfi srfi-1)
+ #:export (set-record-type-printer!
+ define-immutable-record-type
+ set-field
+ set-fields))
(define (set-record-type-printer! type thunk)
"Set a custom printer THUNK for TYPE."
(struct-set! type vtable-index-printer thunk))
+
+(define-syntax-rule (define-immutable-record-type name ctor pred fields ...)
+ ((@@ (srfi srfi-9) %define-record-type) #t name ctor pred fields ...))
+
+(define-syntax-rule (set-field (getter ...) s expr)
+ (%set-fields #t (set-field (getter ...) s expr) ()
+ s ((getter ...) expr)))
+
+(define-syntax-rule (set-fields s . rest)
+ (%set-fields #t (set-fields s . rest) ()
+ s . rest))
+
+;;
+;; collate-set-field-specs is a helper for %set-fields
+;; thats combines all specs with the same head together.
+;;
+;; For example:
+;;
+;; SPECS: (((a b c) expr1)
+;; ((a d) expr2)
+;; ((b c) expr3)
+;; ((c) expr4))
+;;
+;; RESULT: ((a ((b c) expr1)
+;; ((d) expr2))
+;; (b ((c) expr3))
+;; (c (() expr4)))
+;;
+(define (collate-set-field-specs specs)
+ (define (insert head tail expr result)
+ (cond ((find (lambda (tree)
+ (free-identifier=? head (car tree)))
+ result)
+ => (lambda (tree)
+ `((,head (,tail ,expr)
+ ,@(cdr tree))
+ ,@(delq tree result))))
+ (else `((,head (,tail ,expr))
+ ,@result))))
+ (with-syntax (((((head . tail) expr) ...) specs))
+ (fold insert '() #'(head ...) #'(tail ...) #'(expr ...))))
+
+(define-syntax %set-fields-unknown-getter
+ (lambda (x)
+ (syntax-case x ()
+ ((_ orig-form getter)
+ (syntax-violation 'set-fields "unknown getter" #'orig-form #'getter)))))
+
+(define-syntax %set-fields
+ (lambda (x)
+ (with-syntax ((getter-type #'(@@ (srfi srfi-9) getter-type))
+ (getter-index #'(@@ (srfi srfi-9) getter-index))
+ (getter-copier #'(@@ (srfi srfi-9) getter-copier)))
+ (syntax-case x ()
+ ((_ check? orig-form (path-so-far ...)
+ s)
+ #'s)
+ ((_ check? orig-form (path-so-far ...)
+ s (() e))
+ #'e)
+ ((_ check? orig-form (path-so-far ...)
+ struct-expr ((head . tail) expr) ...)
+ (let ((collated-specs (collate-set-field-specs
+ #'(((head . tail) expr) ...))))
+ (with-syntax ((getter (caar collated-specs)))
+ (with-syntax ((err #'(%set-fields-unknown-getter
+ orig-form getter)))
+ #`(let ((s struct-expr))
+ ((getter-copier getter err)
+ check?
+ s
+ #,@(map (lambda (spec)
+ (with-syntax (((head (tail expr) ...) spec))
+ (with-syntax ((err #'(%set-fields-unknown-getter
+ orig-form head)))
+ #'(head (%set-fields
+ check?
+ orig-form
+ (path-so-far ... head)
+ (struct-ref s (getter-index head err))
+ (tail expr) ...)))))
+ collated-specs)))))))
+ ((_ check? orig-form (path-so-far ...)
+ s (() e) (() e*) ...)
+ (syntax-violation 'set-fields "duplicate field path"
+ #'orig-form #'(path-so-far ...)))
+ ((_ check? orig-form (path-so-far ...)
+ s ((getter ...) expr) ...)
+ (syntax-violation 'set-fields "one field path is a prefix of another"
+ #'orig-form #'(path-so-far ...)))
+ ((_ check? orig-form . rest)
+ (syntax-violation 'set-fields "invalid syntax" #'orig-form))))))
diff --git a/test-suite/tests/srfi-9.test b/test-suite/tests/srfi-9.test
index 321fe16..54dbaef 100644
--- a/test-suite/tests/srfi-9.test
+++ b/test-suite/tests/srfi-9.test
@@ -20,19 +20,24 @@
(define-module (test-suite test-numbers)
#:use-module (test-suite lib)
#:use-module ((system base compile) #:select (compile))
- #:use-module (srfi srfi-9))
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu))
(define-record-type :qux (make-qux) qux?)
-(define-record-type :foo (make-foo x) foo?
- (x get-x) (y get-y set-y!))
+(define-record-type :foo (make-foo x) foo?
+ (x foo-x)
+ (y foo-y set-foo-y!)
+ (z foo-z set-foo-z!))
-(define-record-type :bar (make-bar i j) bar?
- (i get-i) (i get-j set-j!))
+(define-record-type :bar (make-bar i j) bar?
+ (i bar-i)
+ (j bar-j set-bar-j!))
(define f (make-foo 1))
-(set-y! f 2)
+(set-foo-y! f 2)
(define b (make-bar 123 456))
@@ -63,36 +68,78 @@
(pass-if "fail number"
(eq? #f (foo? 123))))
-(with-test-prefix "accessor"
+(with-test-prefix "getter"
- (pass-if "get-x"
- (= 1 (get-x f)))
- (pass-if "get-y"
- (= 2 (get-y f)))
+ (pass-if "foo-x"
+ (= 1 (foo-x f)))
+ (pass-if "foo-y"
+ (= 2 (foo-y f)))
- (pass-if-exception "get-x on number" exception:wrong-type-arg
- (get-x 999))
- (pass-if-exception "get-y on number" exception:wrong-type-arg
- (get-y 999))
+ (pass-if-exception "foo-x on number" exception:wrong-type-arg
+ (foo-x 999))
+ (pass-if-exception "foo-y on number" exception:wrong-type-arg
+ (foo-y 999))
;; prior to guile 1.6.9 and 1.8.1 this wan't enforced
- (pass-if-exception "get-x on bar" exception:wrong-type-arg
- (get-x b))
- (pass-if-exception "get-y on bar" exception:wrong-type-arg
- (get-y b)))
+ (pass-if-exception "foo-x on bar" exception:wrong-type-arg
+ (foo-x b))
+ (pass-if-exception "foo-y on bar" exception:wrong-type-arg
+ (foo-y b)))
-(with-test-prefix "modifier"
+(with-test-prefix "setter"
- (pass-if "set-y!"
- (set-y! f #t)
- (eq? #t (get-y f)))
+ (pass-if "set-foo-y!"
+ (set-foo-y! f #t)
+ (eq? #t (foo-y f)))
- (pass-if-exception "set-y! on number" exception:wrong-type-arg
- (set-y! 999 #t))
+ (pass-if-exception "set-foo-y! on number" exception:wrong-type-arg
+ (set-foo-y! 999 #t))
;; prior to guile 1.6.9 and 1.8.1 this wan't enforced
- (pass-if-exception "set-y! on bar" exception:wrong-type-arg
- (set-y! b 99)))
+ (pass-if-exception "set-foo-y! on bar" exception:wrong-type-arg
+ (set-foo-y! b 99)))
+
+(with-test-prefix "functional setters"
+
+ (pass-if "set-field"
+ (let ((s (make-foo (make-bar 1 2))))
+ (and (equal? (set-field (foo-x bar-j) s 3)
+ (make-foo (make-bar 1 3)))
+ (equal? (set-field (foo-z) s 'bar)
+ (let ((s2 (make-foo (make-bar 1 2))))
+ (set-foo-z! s2 'bar)
+ s2))
+ (equal? s (make-foo (make-bar 1 2))))))
+
+ (pass-if-exception "set-field on wrong struct type" exception:wrong-type-arg
+ (let ((s (make-bar (make-foo 5) 2)))
+ (set-field (foo-x bar-j) s 3)))
+
+ (pass-if-exception "set-field on number" exception:wrong-type-arg
+ (set-field (foo-x bar-j) 4 3))
+
+ (pass-if "set-fields"
+ (let ((s (make-foo (make-bar 1 2))))
+ (and (equal? (set-field (foo-x bar-j) s 3)
+ (make-foo (make-bar 1 3)))
+ (equal? (set-fields s
+ ((foo-x bar-j) 3)
+ ((foo-z) 'bar))
+ (let ((s2 (make-foo (make-bar 1 3))))
+ (set-foo-z! s2 'bar)
+ s2))
+ (equal? s (make-foo (make-bar 1 2))))))
+
+ (pass-if-exception "set-fields on wrong struct type" exception:wrong-type-arg
+ (let ((s (make-bar (make-foo 5) 2)))
+ (set-fields 4
+ ((foo-x bar-j) 3)
+ ((foo-y) 'bar))))
+
+ (pass-if-exception "set-fields on number" exception:wrong-type-arg
+ (set-fields 4
+ ((foo-x bar-j) 3)
+ ((foo-z) 'bar))))
(with-test-prefix "side-effecting arguments"
@@ -109,7 +156,247 @@
(pass-if "construction"
(let ((frotz (make-frotz 1 2)))
(and (= (frotz-a frotz) 1)
- (= (frotz-b frotz) 2)))))
+ (= (frotz-b frotz) 2))))
+
+ (with-test-prefix "functional setters"
+ (let ()
+ (define-record-type foo (make-foo x) foo?
+ (x foo-x)
+ (y foo-y set-foo-y!)
+ (z foo-z set-foo-z!))
+
+ (define-record-type :bar (make-bar i j) bar?
+ (i bar-i)
+ (j bar-j set-bar-j!))
+
+ (pass-if "set-field"
+ (let ((s (make-foo (make-bar 1 2))))
+ (and (equal? (set-field (foo-x bar-j) s 3)
+ (make-foo (make-bar 1 3)))
+ (equal? (set-field (foo-z) s 'bar)
+ (let ((s2 (make-foo (make-bar 1 2))))
+ (set-foo-z! s2 'bar)
+ s2))
+ (equal? s (make-foo (make-bar 1 2)))))))
+
+ (pass-if "set-fields"
+
+ (let ((s (make-foo (make-bar 1 2))))
+ (and (equal? (set-field (foo-x bar-j) s 3)
+ (make-foo (make-bar 1 3)))
+ (equal? (set-fields s
+ ((foo-x bar-j) 3)
+ ((foo-z) 'bar))
+ (let ((s2 (make-foo (make-bar 1 3))))
+ (set-foo-z! s2 'bar)
+ s2))
+ (equal? s (make-foo (make-bar 1 2))))))))
+
+\f
+(define-immutable-record-type :baz
+ (make-baz x y z)
+ baz?
+ (x baz-x set-baz-x)
+ (y baz-y set-baz-y)
+ (z baz-z set-baz-z))
+
+(define-immutable-record-type :address
+ (make-address street city country)
+ address?
+ (street address-street)
+ (city address-city)
+ (country address-country))
+
+(define-immutable-record-type :person
+ (make-person age email address)
+ person?
+ (age person-age)
+ (email person-email)
+ (address person-address))
+
+(with-test-prefix "define-immutable-record-type"
+
+ (pass-if "get"
+ (let ((b (make-baz 1 2 3)))
+ (and (= (baz-x b) 1)
+ (= (baz-y b) 2)
+ (= (baz-z b) 3))))
+
+ (pass-if "get non-inlined"
+ (let ((b (make-baz 1 2 3)))
+ (equal? (map (cute apply <> (list b))
+ (list baz-x baz-y baz-z))
+ '(1 2 3))))
+
+ (pass-if "set"
+ (let* ((b0 (make-baz 1 2 3))
+ (b1 (set-baz-x b0 11))
+ (b2 (set-baz-y b1 22))
+ (b3 (set-baz-z b2 33)))
+ (and (= (baz-x b0) 1)
+ (= (baz-x b1) 11) (= (baz-x b2) 11) (= (baz-x b3) 11)
+ (= (baz-y b0) 2) (= (baz-y b1) 2)
+ (= (baz-y b2) 22) (= (baz-y b3) 22)
+ (= (baz-z b0) 3) (= (baz-z b1) 3) (= (baz-z b2) 3)
+ (= (baz-z b3) 33))))
+
+ (pass-if "set non-inlined"
+ (let ((set (compose (cut set-baz-x <> 1)
+ (cut set-baz-y <> 2)
+ (cut set-baz-z <> 3))))
+ (equal? (set (make-baz 0 0 0)) (make-baz 1 2 3))))
+
+ (pass-if "set-field"
+ (let ((p (make-person 30 "foo@example.com"
+ (make-address "Foo" "Paris" "France"))))
+ (and (equal? (set-field (person-address address-street) p "Bar")
+ (make-person 30 "foo@example.com"
+ (make-address "Bar" "Paris" "France")))
+ (equal? (set-field (person-email) p "bar@example.com")
+ (make-person 30 "bar@example.com"
+ (make-address "Foo" "Paris" "France")))
+ (equal? p (make-person 30 "foo@example.com"
+ (make-address "Foo" "Paris" "France"))))))
+
+ (pass-if "set-fields"
+ (let ((p (make-person 30 "foo@example.com"
+ (make-address "Foo" "Paris" "France"))))
+ (and (equal? (set-fields p
+ ((person-email) "bar@example.com")
+ ((person-address address-country) "Spain")
+ ((person-address address-city) "Barcelona"))
+ (make-person 30 "bar@example.com"
+ (make-address "Foo" "Barcelona" "Spain")))
+ (equal? (set-fields p
+ ((person-email) "bar@example.com")
+ ((person-age) 20))
+ (make-person 20 "bar@example.com"
+ (make-address "Foo" "Paris" "France")))
+ (equal? p (make-person 30 "foo@example.com"
+ (make-address "Foo" "Paris" "France"))))))
+
+ (with-test-prefix "non-toplevel"
+
+ (pass-if "get"
+ (let ()
+ (define-immutable-record-type bar
+ (make-bar x y z)
+ bar?
+ (x bar-x)
+ (y bar-y)
+ (z bar-z set-bar-z))
+
+ (let ((b (make-bar 1 2 3)))
+ (and (= (bar-x b) 1)
+ (= (bar-y b) 2)
+ (= (bar-z b) 3)))))
+
+ (pass-if "get non-inlined"
+ (let ()
+ (define-immutable-record-type bar
+ (make-bar x y z)
+ bar?
+ (x bar-x)
+ (y bar-y)
+ (z bar-z set-bar-z))
+
+ (let ((b (make-bar 1 2 3)))
+ (equal? (map (cute apply <> (list b))
+ (list bar-x bar-y bar-z))
+ '(1 2 3)))))
+
+ (pass-if "set"
+ (let ()
+ (define-immutable-record-type bar
+ (make-bar x y z)
+ bar?
+ (x bar-x set-bar-x)
+ (y bar-y set-bar-y)
+ (z bar-z set-bar-z))
+
+ (let* ((b0 (make-bar 1 2 3))
+ (b1 (set-bar-x b0 11))
+ (b2 (set-bar-y b1 22))
+ (b3 (set-bar-z b2 33)))
+ (and (= (bar-x b0) 1)
+ (= (bar-x b1) 11) (= (bar-x b2) 11) (= (bar-x b3) 11)
+ (= (bar-y b0) 2) (= (bar-y b1) 2)
+ (= (bar-y b2) 22) (= (bar-y b3) 22)
+ (= (bar-z b0) 3) (= (bar-z b1) 3) (= (bar-z b2) 3)
+ (= (bar-z b3) 33)))))
+
+ (pass-if "set non-inlined"
+ (let ()
+ (define-immutable-record-type bar
+ (make-bar x y z)
+ bar?
+ (x bar-x set-bar-x)
+ (y bar-y set-bar-y)
+ (z bar-z set-bar-z))
+
+ (let ((set (compose (cut set-bar-x <> 1)
+ (cut set-bar-y <> 2)
+ (cut set-bar-z <> 3))))
+ (equal? (set (make-bar 0 0 0)) (make-bar 1 2 3)))))
+
+ (pass-if "set-field"
+ (let ()
+ (define-immutable-record-type address
+ (make-address street city country)
+ address?
+ (street address-street)
+ (city address-city)
+ (country address-country))
+
+ (define-immutable-record-type :person
+ (make-person age email address)
+ person?
+ (age person-age)
+ (email person-email)
+ (address person-address))
+
+ (let ((p (make-person 30 "foo@example.com"
+ (make-address "Foo" "Paris" "France"))))
+ (and (equal? (set-field (person-address address-street) p "Bar")
+ (make-person 30 "foo@example.com"
+ (make-address "Bar" "Paris" "France")))
+ (equal? (set-field (person-email) p "bar@example.com")
+ (make-person 30 "bar@example.com"
+ (make-address "Foo" "Paris" "France")))
+ (equal? p (make-person 30 "foo@example.com"
+ (make-address "Foo" "Paris" "France")))))))
+
+ (pass-if "set-fields"
+ (let ()
+ (define-immutable-record-type address
+ (make-address street city country)
+ address?
+ (street address-street)
+ (city address-city)
+ (country address-country))
+
+ (define-immutable-record-type :person
+ (make-person age email address)
+ person?
+ (age person-age)
+ (email person-email)
+ (address person-address))
+
+ (let ((p (make-person 30 "foo@example.com"
+ (make-address "Foo" "Paris" "France"))))
+ (and (equal? (set-fields p
+ ((person-email) "bar@example.com")
+ ((person-address address-country) "Spain")
+ ((person-address address-city) "Barcelona"))
+ (make-person 30 "bar@example.com"
+ (make-address "Foo" "Barcelona" "Spain")))
+ (equal? (set-fields p
+ ((person-email) "bar@example.com")
+ ((person-age) 20))
+ (make-person 20 "bar@example.com"
+ (make-address "Foo" "Paris" "France")))
+ (equal? p (make-person 30 "foo@example.com"
+ (make-address "Foo" "Paris" "France")))))))))
(with-test-prefix "record compatibility"
@@ -119,3 +406,8 @@
(pass-if "record-constructor"
(equal? ((record-constructor :foo) 1)
(make-foo 1))))
+
+;;; Local Variables:
+;;; mode: scheme
+;;; eval: (put 'set-fields 'scheme-indent-function 1)
+;;; End:
--
1.7.10.4
^ permalink raw reply related [flat|nested] 22+ messages in thread
* Re: Functional record "setters", a different approach
2012-11-07 20:04 ` Mark H Weaver
@ 2012-11-08 5:15 ` Mark H Weaver
2012-11-08 19:09 ` Ludovic Courtès
0 siblings, 1 reply; 22+ messages in thread
From: Mark H Weaver @ 2012-11-08 5:15 UTC (permalink / raw)
To: guile-devel
[-- Attachment #1: Type: text/plain, Size: 3007 bytes --]
Hello all,
I've attached a slightly improved functional record "setters" patch.
The only change since yesterday's version is to the test suite, which
now includes tests of the compile-time error checking.
Here's a brief overview of the provided functionality.
First, 'define-immutable-record-type' is very similar to SRFI-9's
'define-record-type', but the (optional) third element of each field
spec is a purely functional record setter. Unlike the usual destructive
setters which mutate a record in place, a functional record "setter"
returns a freshly allocated record that's the same as the existing one
but with one field changed, e.g.:
(use-modules (srfi srfi-9)
(srfi srfi-9 gnu))
(define-immutable-record-type address
(make-address street city)
address?
(street address-street set-address-street)
(city address-city set-address-city))
(define addr (make-address "Foo" "Paris"))
addr
=> #<address street: "Foo" city: "Paris">
(set-address-street addr "Bar")
=> #<address street: "Bar" city: "Paris">
addr
=> #<address street: "Foo" city: "Paris">
'set-field' allows you to non-destructively "set" a field at an
arbitrary depth within a nested structure, e.g.:
(define-immutable-record-type person
(make-person age email address)
person?
(age person-age)
(email person-email)
(address person-address))
(define p (make-person 30 "foo@example.com"
(make-address "Foo" "Paris")))
p
=> #<person age: 30 email: "foo@example.com"
address: #<address street: "Foo" city: "Paris">>
(set-field (person-address address-city) p "Düsseldorf")
=> #<person age: 30 email: "foo@example.com"
address: #<address street: "Foo" city: "Düsseldorf">>
p
=> #<person age: 30 email: "foo@example.com"
address: #<address street: "Foo" city: "Paris">>
'set-fields' allows you to non-destructively "set" any number of fields
(of arbitrary depth), and accomplishes this with the minimal number of
allocations, sharing as much as possible with the original structure.
(set-fields p
((person-email) "bar@example.com")
((person-address address-city) "Düsseldorf"))
=> #<person age: 30 email: "bar@example.com"
address: #<address street: "Foo" city: "Düsseldorf">>
(define p2 (set-fields p
((person-age) 20)
((person-email) "foobar@example.com")))
p2
=> #<person age: 20 email: "foobar@example.com"
address: #<address street: "Foo" city: "Paris">>
(eq? (person-address p) (person-address p2))
=> #t
Note that 'set-field' and 'set-fields' can also be used with traditional
mutable SRFI-9 records, or any mixture of mutable and immutable records.
Comments and suggestions solicited.
Mark
[-- Attachment #2: [PATCH] Implement functional record setters --]
[-- Type: text/x-diff, Size: 41853 bytes --]
From 274c795382308f537aea620c3972cff291624cce Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
Date: Wed, 7 Nov 2012 12:21:44 -0500
Subject: [PATCH] Implement functional record setters.
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Written in collaboration with Ludovic Courtès <ludo@gnu.org>
* module/srfi/srfi-9.scm: Internally, rename 'accessor' to 'getter'
and 'modifier' to 'setter'.
(define-tagged-inlinable, getter-type, getter-index, getter-copier,
%%on-error, %%set-fields): New macros.
(%define-record-type): New macro for creating both mutable and
immutable records, and containing a substantially rewritten version of
the code formerly in 'define-record-type'.
(define-record-type): Now just a wrapper for '%define-record-type'.
(throw-bad-struct, make-copier-id): New procedures.
* module/srfi/srfi-9/gnu.scm (define-immutable-record-type, set-field,
and set-fields): New exported macros.
(collate-set-field-specs): New procedure.
(%set-fields-unknown-getter, %set-fields): New macros.
* test-suite/tests/srfi-9.test: Add tests. Rename getters and setters
in existing tests to make the functional setters look better.
---
module/srfi/srfi-9.scm | 252 ++++++++++++-------
module/srfi/srfi-9/gnu.scm | 100 +++++++-
test-suite/tests/srfi-9.test | 544 +++++++++++++++++++++++++++++++++++++++---
3 files changed, 785 insertions(+), 111 deletions(-)
diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm
index da71d1e..1dd132a 100644
--- a/module/srfi/srfi-9.scm
+++ b/module/srfi/srfi-9.scm
@@ -29,8 +29,8 @@
;; <predicate name>
;; <field spec> ...)
;;
-;; <field spec> -> (<field tag> <accessor name>)
-;; -> (<field tag> <accessor name> <modifier name>)
+;; <field spec> -> (<field tag> <getter name>)
+;; -> (<field tag> <getter name> <setter name>)
;;
;; <field tag> -> <identifier>
;; <... name> -> <identifier>
@@ -68,8 +68,31 @@
;; because the public one has a different `make-procedure-name', so
;; using it would require users to recompile code that uses SRFI-9. See
;; <http://lists.gnu.org/archive/html/guile-devel/2011-04/msg00111.html>.
+;;
+
+(define-syntax-rule (define-inlinable (name formals ...) body ...)
+ (define-tagged-inlinable () (name formals ...) body ...))
+
+;; 'define-tagged-inlinable' has an additional feature: it stores a map
+;; of keys to values that can be retrieved at expansion time. This is
+;; currently used to retrieve the rtd id, field index, and record copier
+;; macro for an arbitrary getter.
+
+(define-syntax-rule (%%on-error err) err)
+
+(define %%type #f) ; a private syntax literal
+(define-syntax-rule (getter-type getter err)
+ (getter (%%on-error err) %%type))
-(define-syntax define-inlinable
+(define %%index #f) ; a private syntax literal
+(define-syntax-rule (getter-index getter err)
+ (getter (%%on-error err) %%index))
+
+(define %%copier #f) ; a private syntax literal
+(define-syntax-rule (getter-copier getter err)
+ (getter (%%on-error err) %%copier))
+
+(define-syntax define-tagged-inlinable
(lambda (x)
(define (make-procedure-name name)
(datum->syntax name
@@ -77,7 +100,7 @@
'-procedure)))
(syntax-case x ()
- ((_ (name formals ...) body ...)
+ ((_ ((key value) ...) (name formals ...) body ...)
(identifier? #'name)
(with-syntax ((proc-name (make-procedure-name #'name))
((args ...) (generate-temporaries #'(formals ...))))
@@ -86,7 +109,8 @@
body ...)
(define-syntax name
(lambda (x)
- (syntax-case x ()
+ (syntax-case x (%%on-error key ...)
+ ((_ (%%on-error err) key) #'value) ...
((_ args ...)
#'((lambda (formals ...)
body ...)
@@ -109,90 +133,149 @@
(loop (cdr fields) (+ 1 off)))))
(display ">" p))
-(define-syntax define-record-type
+(define (throw-bad-struct s who)
+ (throw 'wrong-type-arg who
+ "Wrong type argument: ~S" (list s)
+ (list s)))
+
+(define (make-copier-id type-name)
+ (datum->syntax type-name
+ (symbol-append '%% (syntax->datum type-name)
+ '-set-fields)))
+
+(define-syntax %%set-fields
+ (lambda (x)
+ (syntax-case x ()
+ ((_ type-name (getter-id ...) check? s (getter expr) ...)
+ (every identifier? #'(getter ...))
+ (let ((copier-name (syntax->datum (make-copier-id #'type-name)))
+ (getter+exprs #'((getter expr) ...)))
+ (define (lookup id default-expr)
+ (let ((results
+ (filter (lambda (g+e)
+ (free-identifier=? id (car g+e)))
+ getter+exprs)))
+ (case (length results)
+ ((0) default-expr)
+ ((1) (cadar results))
+ (else (syntax-violation
+ copier-name "duplicate getter" x id)))))
+ (for-each (lambda (id)
+ (or (find (lambda (getter-id)
+ (free-identifier=? id getter-id))
+ #'(getter-id ...))
+ (syntax-violation
+ copier-name "unknown getter" x id)))
+ #'(getter ...))
+ (with-syntax ((unsafe-expr
+ #`(make-struct
+ type-name 0
+ #,@(map (lambda (getter index)
+ (lookup getter #`(struct-ref s #,index)))
+ #'(getter-id ...)
+ (iota (length #'(getter-id ...)))))))
+ (if (syntax->datum #'check?)
+ #`(if (eq? (struct-vtable s) type-name)
+ unsafe-expr
+ (throw-bad-struct
+ s '#,(datum->syntax #'here copier-name)))
+ #'unsafe-expr)))))))
+
+(define-syntax %define-record-type
(lambda (x)
(define (field-identifiers field-specs)
- (syntax-case field-specs ()
- (()
- '())
- ((field-spec)
- (syntax-case #'field-spec ()
- ((name accessor) #'(name))
- ((name accessor modifier) #'(name))))
- ((field-spec rest ...)
- (append (field-identifiers #'(field-spec))
- (field-identifiers #'(rest ...))))))
-
- (define (field-indices fields)
- (fold (lambda (field result)
- (let ((i (if (null? result)
- 0
- (+ 1 (cdar result)))))
- (alist-cons field i result)))
- '()
- fields))
-
- (define (constructor type-name constructor-spec indices)
+ (map (lambda (field-spec)
+ (syntax-case field-spec ()
+ ((name getter) #'name)
+ ((name getter setter) #'name)))
+ field-specs))
+
+ (define (getter-identifiers field-specs)
+ (map (lambda (field-spec)
+ (syntax-case field-spec ()
+ ((name getter) #'getter)
+ ((name getter setter) #'getter)))
+ field-specs))
+
+ (define (constructor form type-name constructor-spec field-names)
(syntax-case constructor-spec ()
((ctor field ...)
- (let ((field-count (length indices))
- (ctor-args (map (lambda (field)
- (cons (syntax->datum field) field))
- #'(field ...))))
+ (every identifier? #'(field ...))
+ (let ((ctor-args (map (lambda (field)
+ (let ((name (syntax->datum field)))
+ (or (memq name field-names)
+ (syntax-violation
+ 'define-record-type
+ "unknown field in constructor-spec"
+ form field))
+ (cons name field)))
+ #'(field ...))))
#`(define-inlinable #,constructor-spec
(make-struct #,type-name 0
- #,@(unfold
- (lambda (field-num)
- (>= field-num field-count))
- (lambda (field-num)
- (let* ((name
- (car (find (lambda (f+i)
- (= (cdr f+i) field-num))
- indices)))
- (arg (assq name ctor-args)))
- (if (pair? arg)
- (cdr arg)
- #'#f)))
- 1+
- 0)))))))
-
- (define (accessors type-name field-specs indices)
- (syntax-case field-specs ()
- (()
- #'())
- ((field-spec)
- (syntax-case #'field-spec ()
- ((name accessor)
- (with-syntax ((index (assoc-ref indices (syntax->datum #'name))))
- #`((define-inlinable (accessor s)
- (if (eq? (struct-vtable s) #,type-name)
- (struct-ref s index)
- (throw 'wrong-type-arg 'accessor
- "Wrong type argument: ~S" (list s)
- (list s)))))))
- ((name accessor modifier)
- (with-syntax ((index (assoc-ref indices (syntax->datum #'name))))
- #`(#,@(accessors type-name #'((name accessor)) indices)
- (define-inlinable (modifier s val)
- (if (eq? (struct-vtable s) #,type-name)
- (struct-set! s index val)
- (throw 'wrong-type-arg 'modifier
- "Wrong type argument: ~S" (list s)
- (list s)))))))))
- ((field-spec rest ...)
- #`(#,@(accessors type-name #'(field-spec) indices)
- #,@(accessors type-name #'(rest ...) indices)))))
+ #,@(map (lambda (name)
+ (assq-ref ctor-args name))
+ field-names)))))))
+
+ (define (getters type-name getter-ids copier-id)
+ (map (lambda (getter index)
+ #`(define-tagged-inlinable
+ ((%%type #,type-name)
+ (%%index #,index)
+ (%%copier #,copier-id))
+ (#,getter s)
+ (if (eq? (struct-vtable s) #,type-name)
+ (struct-ref s #,index)
+ (throw-bad-struct s '#,getter))))
+ getter-ids
+ (iota (length getter-ids))))
+
+ (define (copier type-name getter-ids copier-id)
+ #`(define-syntax-rule
+ (#,copier-id check? s (getter expr) (... ...))
+ (%%set-fields #,type-name #,getter-ids
+ check? s (getter expr) (... ...))))
+
+ (define (setters type-name field-specs)
+ (filter-map (lambda (field-spec index)
+ (syntax-case field-spec ()
+ ((name getter) #f)
+ ((name getter setter)
+ #`(define-inlinable (setter s val)
+ (if (eq? (struct-vtable s) #,type-name)
+ (struct-set! s #,index val)
+ (throw-bad-struct s 'setter))))))
+ field-specs
+ (iota (length field-specs))))
+
+ (define (functional-setters copier-id field-specs)
+ (filter-map (lambda (field-spec index)
+ (syntax-case field-spec ()
+ ((name getter) #f)
+ ((name getter setter)
+ #`(define-inlinable (setter s val)
+ (#,copier-id #t s (getter val))))))
+ field-specs
+ (iota (length field-specs))))
+
+ (define (record-layout immutable? count)
+ (let ((desc (if immutable? "pr" "pw")))
+ (string-concatenate (make-list count desc))))
(syntax-case x ()
- ((_ type-name constructor-spec predicate-name field-spec ...)
- (let* ((fields (field-identifiers #'(field-spec ...)))
- (field-count (length fields))
- (layout (string-concatenate (make-list field-count "pw")))
- (indices (field-indices (map syntax->datum fields)))
+ ((_ immutable? type-name constructor-spec predicate-name
+ field-spec ...)
+ (boolean? (syntax->datum #'immutable?))
+ (let* ((field-ids (field-identifiers #'(field-spec ...)))
+ (getter-ids (getter-identifiers #'(field-spec ...)))
+ (field-count (length field-ids))
+ (immutable? (syntax->datum #'immutable?))
+ (layout (record-layout immutable? field-count))
+ (field-names (map syntax->datum field-ids))
(ctor-name (syntax-case #'constructor-spec ()
- ((ctor args ...) #'ctor))))
+ ((ctor args ...) #'ctor)))
+ (copier-id (make-copier-id #'type-name)))
#`(begin
- #,(constructor #'type-name #'constructor-spec indices)
+ #,(constructor x #'type-name #'constructor-spec field-names)
(define type-name
(let ((rtd (make-struct/no-tail
@@ -200,7 +283,7 @@
'#,(datum->syntax #'here (make-struct-layout layout))
default-record-printer
'type-name
- '#,fields)))
+ '#,field-ids)))
(set-struct-vtable-name! rtd 'type-name)
(struct-set! rtd (+ 2 vtable-offset-user) #,ctor-name)
rtd))
@@ -209,6 +292,13 @@
(and (struct? obj)
(eq? (struct-vtable obj) type-name)))
- #,@(accessors #'type-name #'(field-spec ...) indices)))))))
+ #,@(getters #'type-name getter-ids copier-id)
+ #,(copier #'type-name getter-ids copier-id)
+ #,@(if immutable?
+ (functional-setters copier-id #'(field-spec ...))
+ (setters #'type-name #'(field-spec ...)))))))))
+
+(define-syntax-rule (define-record-type name ctor pred fields ...)
+ (%define-record-type #f name ctor pred fields ...))
;;; srfi-9.scm ends here
diff --git a/module/srfi/srfi-9/gnu.scm b/module/srfi/srfi-9/gnu.scm
index 30c101b..fa091fe 100644
--- a/module/srfi/srfi-9/gnu.scm
+++ b/module/srfi/srfi-9/gnu.scm
@@ -1,6 +1,6 @@
;;; Extensions to SRFI-9
-;; Copyright (C) 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2012 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@@ -23,8 +23,104 @@
;;; Code:
(define-module (srfi srfi-9 gnu)
- #:export (set-record-type-printer!))
+ #:use-module (srfi srfi-1)
+ #:export (set-record-type-printer!
+ define-immutable-record-type
+ set-field
+ set-fields))
(define (set-record-type-printer! type thunk)
"Set a custom printer THUNK for TYPE."
(struct-set! type vtable-index-printer thunk))
+
+(define-syntax-rule (define-immutable-record-type name ctor pred fields ...)
+ ((@@ (srfi srfi-9) %define-record-type) #t name ctor pred fields ...))
+
+(define-syntax-rule (set-field (getter ...) s expr)
+ (%set-fields #t (set-field (getter ...) s expr) ()
+ s ((getter ...) expr)))
+
+(define-syntax-rule (set-fields s . rest)
+ (%set-fields #t (set-fields s . rest) ()
+ s . rest))
+
+;;
+;; collate-set-field-specs is a helper for %set-fields
+;; thats combines all specs with the same head together.
+;;
+;; For example:
+;;
+;; SPECS: (((a b c) expr1)
+;; ((a d) expr2)
+;; ((b c) expr3)
+;; ((c) expr4))
+;;
+;; RESULT: ((a ((b c) expr1)
+;; ((d) expr2))
+;; (b ((c) expr3))
+;; (c (() expr4)))
+;;
+(define (collate-set-field-specs specs)
+ (define (insert head tail expr result)
+ (cond ((find (lambda (tree)
+ (free-identifier=? head (car tree)))
+ result)
+ => (lambda (tree)
+ `((,head (,tail ,expr)
+ ,@(cdr tree))
+ ,@(delq tree result))))
+ (else `((,head (,tail ,expr))
+ ,@result))))
+ (with-syntax (((((head . tail) expr) ...) specs))
+ (fold insert '() #'(head ...) #'(tail ...) #'(expr ...))))
+
+(define-syntax %set-fields-unknown-getter
+ (lambda (x)
+ (syntax-case x ()
+ ((_ orig-form getter)
+ (syntax-violation 'set-fields "unknown getter" #'orig-form #'getter)))))
+
+(define-syntax %set-fields
+ (lambda (x)
+ (with-syntax ((getter-type #'(@@ (srfi srfi-9) getter-type))
+ (getter-index #'(@@ (srfi srfi-9) getter-index))
+ (getter-copier #'(@@ (srfi srfi-9) getter-copier)))
+ (syntax-case x ()
+ ((_ check? orig-form (path-so-far ...)
+ s)
+ #'s)
+ ((_ check? orig-form (path-so-far ...)
+ s (() e))
+ #'e)
+ ((_ check? orig-form (path-so-far ...)
+ struct-expr ((head . tail) expr) ...)
+ (let ((collated-specs (collate-set-field-specs
+ #'(((head . tail) expr) ...))))
+ (with-syntax ((getter (caar collated-specs)))
+ (with-syntax ((err #'(%set-fields-unknown-getter
+ orig-form getter)))
+ #`(let ((s struct-expr))
+ ((getter-copier getter err)
+ check?
+ s
+ #,@(map (lambda (spec)
+ (with-syntax (((head (tail expr) ...) spec))
+ (with-syntax ((err #'(%set-fields-unknown-getter
+ orig-form head)))
+ #'(head (%set-fields
+ check?
+ orig-form
+ (path-so-far ... head)
+ (struct-ref s (getter-index head err))
+ (tail expr) ...)))))
+ collated-specs)))))))
+ ((_ check? orig-form (path-so-far ...)
+ s (() e) (() e*) ...)
+ (syntax-violation 'set-fields "duplicate field path"
+ #'orig-form #'(path-so-far ...)))
+ ((_ check? orig-form (path-so-far ...)
+ s ((getter ...) expr) ...)
+ (syntax-violation 'set-fields "one field path is a prefix of another"
+ #'orig-form #'(path-so-far ...)))
+ ((_ check? orig-form . rest)
+ (syntax-violation 'set-fields "invalid syntax" #'orig-form))))))
diff --git a/test-suite/tests/srfi-9.test b/test-suite/tests/srfi-9.test
index 321fe16..8d739e4 100644
--- a/test-suite/tests/srfi-9.test
+++ b/test-suite/tests/srfi-9.test
@@ -20,19 +20,24 @@
(define-module (test-suite test-numbers)
#:use-module (test-suite lib)
#:use-module ((system base compile) #:select (compile))
- #:use-module (srfi srfi-9))
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu))
(define-record-type :qux (make-qux) qux?)
-(define-record-type :foo (make-foo x) foo?
- (x get-x) (y get-y set-y!))
+(define-record-type :foo (make-foo x) foo?
+ (x foo-x)
+ (y foo-y set-foo-y!)
+ (z foo-z set-foo-z!))
-(define-record-type :bar (make-bar i j) bar?
- (i get-i) (i get-j set-j!))
+(define-record-type :bar (make-bar i j) bar?
+ (i bar-i)
+ (j bar-j set-bar-j!))
(define f (make-foo 1))
-(set-y! f 2)
+(set-foo-y! f 2)
(define b (make-bar 123 456))
@@ -63,36 +68,169 @@
(pass-if "fail number"
(eq? #f (foo? 123))))
-(with-test-prefix "accessor"
+(with-test-prefix "getter"
- (pass-if "get-x"
- (= 1 (get-x f)))
- (pass-if "get-y"
- (= 2 (get-y f)))
+ (pass-if "foo-x"
+ (= 1 (foo-x f)))
+ (pass-if "foo-y"
+ (= 2 (foo-y f)))
- (pass-if-exception "get-x on number" exception:wrong-type-arg
- (get-x 999))
- (pass-if-exception "get-y on number" exception:wrong-type-arg
- (get-y 999))
+ (pass-if-exception "foo-x on number" exception:wrong-type-arg
+ (foo-x 999))
+ (pass-if-exception "foo-y on number" exception:wrong-type-arg
+ (foo-y 999))
;; prior to guile 1.6.9 and 1.8.1 this wan't enforced
- (pass-if-exception "get-x on bar" exception:wrong-type-arg
- (get-x b))
- (pass-if-exception "get-y on bar" exception:wrong-type-arg
- (get-y b)))
+ (pass-if-exception "foo-x on bar" exception:wrong-type-arg
+ (foo-x b))
+ (pass-if-exception "foo-y on bar" exception:wrong-type-arg
+ (foo-y b)))
-(with-test-prefix "modifier"
+(with-test-prefix "setter"
- (pass-if "set-y!"
- (set-y! f #t)
- (eq? #t (get-y f)))
+ (pass-if "set-foo-y!"
+ (set-foo-y! f #t)
+ (eq? #t (foo-y f)))
- (pass-if-exception "set-y! on number" exception:wrong-type-arg
- (set-y! 999 #t))
+ (pass-if-exception "set-foo-y! on number" exception:wrong-type-arg
+ (set-foo-y! 999 #t))
;; prior to guile 1.6.9 and 1.8.1 this wan't enforced
- (pass-if-exception "set-y! on bar" exception:wrong-type-arg
- (set-y! b 99)))
+ (pass-if-exception "set-foo-y! on bar" exception:wrong-type-arg
+ (set-foo-y! b 99)))
+
+(with-test-prefix "functional setters"
+
+ (pass-if "set-field"
+ (let ((s (make-foo (make-bar 1 2))))
+ (and (equal? (set-field (foo-x bar-j) s 3)
+ (make-foo (make-bar 1 3)))
+ (equal? (set-field (foo-z) s 'bar)
+ (let ((s2 (make-foo (make-bar 1 2))))
+ (set-foo-z! s2 'bar)
+ s2))
+ (equal? s (make-foo (make-bar 1 2))))))
+
+ (pass-if-exception "set-field on wrong struct type" exception:wrong-type-arg
+ (let ((s (make-bar (make-foo 5) 2)))
+ (set-field (foo-x bar-j) s 3)))
+
+ (pass-if-exception "set-field on number" exception:wrong-type-arg
+ (set-field (foo-x bar-j) 4 3))
+
+ (pass-if "set-field with unknown first getter"
+ (catch 'syntax-error
+ (lambda ()
+ (compile '(let ((s (make-bar (make-foo 5) 2)))
+ (set-field (blah) s 3))
+ #:env (current-module))
+ #f)
+ (lambda (key whom what src form subform)
+ (equal? (list key whom what form subform)
+ '(syntax-error set-fields "unknown getter"
+ (set-field (blah) s 3)
+ blah)))))
+
+ (pass-if "set-field with unknown second getter"
+ (catch 'syntax-error
+ (lambda ()
+ (compile '(let ((s (make-bar (make-foo 5) 2)))
+ (set-field (bar-j blah) s 3))
+ #:env (current-module))
+ #f)
+ (lambda (key whom what src form subform)
+ (equal? (list key whom what form subform)
+ '(syntax-error set-fields "unknown getter"
+ (set-field (bar-j blah) s 3)
+ blah)))))
+
+ (pass-if "set-fields"
+ (let ((s (make-foo (make-bar 1 2))))
+ (and (equal? (set-field (foo-x bar-j) s 3)
+ (make-foo (make-bar 1 3)))
+ (equal? (set-fields s
+ ((foo-x bar-j) 3)
+ ((foo-z) 'bar))
+ (let ((s2 (make-foo (make-bar 1 3))))
+ (set-foo-z! s2 'bar)
+ s2))
+ (equal? s (make-foo (make-bar 1 2))))))
+
+ (pass-if-exception "set-fields on wrong struct type" exception:wrong-type-arg
+ (let ((s (make-bar (make-foo 5) 2)))
+ (set-fields 4
+ ((foo-x bar-j) 3)
+ ((foo-y) 'bar))))
+
+ (pass-if-exception "set-fields on number" exception:wrong-type-arg
+ (set-fields 4
+ ((foo-x bar-j) 3)
+ ((foo-z) 'bar)))
+
+ (pass-if "set-fields with unknown first getter"
+ (catch 'syntax-error
+ (lambda ()
+ (compile '(let ((s (make-bar (make-foo 5) 2)))
+ (set-fields s ((bar-i foo-x) 1) ((blah) 3)))
+ #:env (current-module))
+ #f)
+ (lambda (key whom what src form subform)
+ (equal? (list key whom what form subform)
+ '(syntax-error set-fields "unknown getter"
+ (set-fields s ((bar-i foo-x) 1) ((blah) 3))
+ blah)))))
+
+ (pass-if "set-fields with unknown second getter"
+ (catch 'syntax-error
+ (lambda ()
+ (compile '(let ((s (make-bar (make-foo 5) 2)))
+ (set-fields s ((bar-i foo-x) 1) ((blah) 3)))
+ #:env (current-module))
+ #f)
+ (lambda (key whom what src form subform)
+ (equal? (list key whom what form subform)
+ '(syntax-error set-fields "unknown getter"
+ (set-fields s ((bar-i foo-x) 1) ((blah) 3))
+ blah)))))
+
+ (pass-if "set-fields with duplicate field path"
+ (catch 'syntax-error
+ (lambda ()
+ (compile '(let ((s (make-bar (make-foo 5) 2)))
+ (set-fields s
+ ((bar-i foo-x) 1)
+ ((bar-i foo-z) 2)
+ ((bar-i foo-x) 3)))
+ #:env (current-module))
+ #f)
+ (lambda (key whom what src form subform)
+ (equal? (list key whom what form subform)
+ '(syntax-error set-fields "duplicate field path"
+ (set-fields s
+ ((bar-i foo-x) 1)
+ ((bar-i foo-z) 2)
+ ((bar-i foo-x) 3))
+ (bar-i foo-x))))))
+
+ (pass-if "set-fields with one path as a prefix of another"
+ (catch 'syntax-error
+ (lambda ()
+ (compile '(let ((s (make-bar (make-foo 5) 2)))
+ (set-fields s
+ ((bar-i foo-x) 1)
+ ((bar-i foo-z) 2)
+ ((bar-i) 3)))
+ #:env (current-module))
+ #f)
+ (lambda (key whom what src form subform)
+ (equal? (list key whom what form subform)
+ '(syntax-error set-fields
+ "one field path is a prefix of another"
+ (set-fields s
+ ((bar-i foo-x) 1)
+ ((bar-i foo-z) 2)
+ ((bar-i) 3))
+ (bar-i)))))))
(with-test-prefix "side-effecting arguments"
@@ -109,7 +247,352 @@
(pass-if "construction"
(let ((frotz (make-frotz 1 2)))
(and (= (frotz-a frotz) 1)
- (= (frotz-b frotz) 2)))))
+ (= (frotz-b frotz) 2))))
+
+ (with-test-prefix "functional setters"
+ (let ()
+ (define-record-type foo (make-foo x) foo?
+ (x foo-x)
+ (y foo-y set-foo-y!)
+ (z foo-z set-foo-z!))
+
+ (define-record-type :bar (make-bar i j) bar?
+ (i bar-i)
+ (j bar-j set-bar-j!))
+
+ (pass-if "set-field"
+ (let ((s (make-foo (make-bar 1 2))))
+ (and (equal? (set-field (foo-x bar-j) s 3)
+ (make-foo (make-bar 1 3)))
+ (equal? (set-field (foo-z) s 'bar)
+ (let ((s2 (make-foo (make-bar 1 2))))
+ (set-foo-z! s2 'bar)
+ s2))
+ (equal? s (make-foo (make-bar 1 2)))))))
+
+ (pass-if "set-fields"
+
+ (let ((s (make-foo (make-bar 1 2))))
+ (and (equal? (set-field (foo-x bar-j) s 3)
+ (make-foo (make-bar 1 3)))
+ (equal? (set-fields s
+ ((foo-x bar-j) 3)
+ ((foo-z) 'bar))
+ (let ((s2 (make-foo (make-bar 1 3))))
+ (set-foo-z! s2 'bar)
+ s2))
+ (equal? s (make-foo (make-bar 1 2))))))))
+
+\f
+(define-immutable-record-type :baz
+ (make-baz x y z)
+ baz?
+ (x baz-x set-baz-x)
+ (y baz-y set-baz-y)
+ (z baz-z set-baz-z))
+
+(define-immutable-record-type :address
+ (make-address street city country)
+ address?
+ (street address-street)
+ (city address-city)
+ (country address-country))
+
+(define-immutable-record-type :person
+ (make-person age email address)
+ person?
+ (age person-age)
+ (email person-email)
+ (address person-address))
+
+(with-test-prefix "define-immutable-record-type"
+
+ (pass-if "get"
+ (let ((b (make-baz 1 2 3)))
+ (and (= (baz-x b) 1)
+ (= (baz-y b) 2)
+ (= (baz-z b) 3))))
+
+ (pass-if "get non-inlined"
+ (let ((b (make-baz 1 2 3)))
+ (equal? (map (cute apply <> (list b))
+ (list baz-x baz-y baz-z))
+ '(1 2 3))))
+
+ (pass-if "set"
+ (let* ((b0 (make-baz 1 2 3))
+ (b1 (set-baz-x b0 11))
+ (b2 (set-baz-y b1 22))
+ (b3 (set-baz-z b2 33)))
+ (and (= (baz-x b0) 1)
+ (= (baz-x b1) 11) (= (baz-x b2) 11) (= (baz-x b3) 11)
+ (= (baz-y b0) 2) (= (baz-y b1) 2)
+ (= (baz-y b2) 22) (= (baz-y b3) 22)
+ (= (baz-z b0) 3) (= (baz-z b1) 3) (= (baz-z b2) 3)
+ (= (baz-z b3) 33))))
+
+ (pass-if "set non-inlined"
+ (let ((set (compose (cut set-baz-x <> 1)
+ (cut set-baz-y <> 2)
+ (cut set-baz-z <> 3))))
+ (equal? (set (make-baz 0 0 0)) (make-baz 1 2 3))))
+
+ (pass-if "set-field"
+ (let ((p (make-person 30 "foo@example.com"
+ (make-address "Foo" "Paris" "France"))))
+ (and (equal? (set-field (person-address address-street) p "Bar")
+ (make-person 30 "foo@example.com"
+ (make-address "Bar" "Paris" "France")))
+ (equal? (set-field (person-email) p "bar@example.com")
+ (make-person 30 "bar@example.com"
+ (make-address "Foo" "Paris" "France")))
+ (equal? p (make-person 30 "foo@example.com"
+ (make-address "Foo" "Paris" "France"))))))
+
+ (pass-if "set-fields"
+ (let ((p (make-person 30 "foo@example.com"
+ (make-address "Foo" "Paris" "France"))))
+ (and (equal? (set-fields p
+ ((person-email) "bar@example.com")
+ ((person-address address-country) "Spain")
+ ((person-address address-city) "Barcelona"))
+ (make-person 30 "bar@example.com"
+ (make-address "Foo" "Barcelona" "Spain")))
+ (equal? (set-fields p
+ ((person-email) "bar@example.com")
+ ((person-age) 20))
+ (make-person 20 "bar@example.com"
+ (make-address "Foo" "Paris" "France")))
+ (equal? p (make-person 30 "foo@example.com"
+ (make-address "Foo" "Paris" "France"))))))
+
+ (with-test-prefix "non-toplevel"
+
+ (pass-if "get"
+ (let ()
+ (define-immutable-record-type bar
+ (make-bar x y z)
+ bar?
+ (x bar-x)
+ (y bar-y)
+ (z bar-z set-bar-z))
+
+ (let ((b (make-bar 1 2 3)))
+ (and (= (bar-x b) 1)
+ (= (bar-y b) 2)
+ (= (bar-z b) 3)))))
+
+ (pass-if "get non-inlined"
+ (let ()
+ (define-immutable-record-type bar
+ (make-bar x y z)
+ bar?
+ (x bar-x)
+ (y bar-y)
+ (z bar-z set-bar-z))
+
+ (let ((b (make-bar 1 2 3)))
+ (equal? (map (cute apply <> (list b))
+ (list bar-x bar-y bar-z))
+ '(1 2 3)))))
+
+ (pass-if "set"
+ (let ()
+ (define-immutable-record-type bar
+ (make-bar x y z)
+ bar?
+ (x bar-x set-bar-x)
+ (y bar-y set-bar-y)
+ (z bar-z set-bar-z))
+
+ (let* ((b0 (make-bar 1 2 3))
+ (b1 (set-bar-x b0 11))
+ (b2 (set-bar-y b1 22))
+ (b3 (set-bar-z b2 33)))
+ (and (= (bar-x b0) 1)
+ (= (bar-x b1) 11) (= (bar-x b2) 11) (= (bar-x b3) 11)
+ (= (bar-y b0) 2) (= (bar-y b1) 2)
+ (= (bar-y b2) 22) (= (bar-y b3) 22)
+ (= (bar-z b0) 3) (= (bar-z b1) 3) (= (bar-z b2) 3)
+ (= (bar-z b3) 33)))))
+
+ (pass-if "set non-inlined"
+ (let ()
+ (define-immutable-record-type bar
+ (make-bar x y z)
+ bar?
+ (x bar-x set-bar-x)
+ (y bar-y set-bar-y)
+ (z bar-z set-bar-z))
+
+ (let ((set (compose (cut set-bar-x <> 1)
+ (cut set-bar-y <> 2)
+ (cut set-bar-z <> 3))))
+ (equal? (set (make-bar 0 0 0)) (make-bar 1 2 3)))))
+
+ (pass-if "set-field"
+ (let ()
+ (define-immutable-record-type address
+ (make-address street city country)
+ address?
+ (street address-street)
+ (city address-city)
+ (country address-country))
+
+ (define-immutable-record-type :person
+ (make-person age email address)
+ person?
+ (age person-age)
+ (email person-email)
+ (address person-address))
+
+ (let ((p (make-person 30 "foo@example.com"
+ (make-address "Foo" "Paris" "France"))))
+ (and (equal? (set-field (person-address address-street) p "Bar")
+ (make-person 30 "foo@example.com"
+ (make-address "Bar" "Paris" "France")))
+ (equal? (set-field (person-email) p "bar@example.com")
+ (make-person 30 "bar@example.com"
+ (make-address "Foo" "Paris" "France")))
+ (equal? p (make-person 30 "foo@example.com"
+ (make-address "Foo" "Paris" "France")))))))
+
+ (pass-if "set-fields"
+ (let ()
+ (define-immutable-record-type address
+ (make-address street city country)
+ address?
+ (street address-street)
+ (city address-city)
+ (country address-country))
+
+ (define-immutable-record-type :person
+ (make-person age email address)
+ person?
+ (age person-age)
+ (email person-email)
+ (address person-address))
+
+ (let ((p (make-person 30 "foo@example.com"
+ (make-address "Foo" "Paris" "France"))))
+ (and (equal? (set-fields p
+ ((person-email) "bar@example.com")
+ ((person-address address-country) "Spain")
+ ((person-address address-city) "Barcelona"))
+ (make-person 30 "bar@example.com"
+ (make-address "Foo" "Barcelona" "Spain")))
+ (equal? (set-fields p
+ ((person-email) "bar@example.com")
+ ((person-age) 20))
+ (make-person 20 "bar@example.com"
+ (make-address "Foo" "Paris" "France")))
+ (equal? p (make-person 30 "foo@example.com"
+ (make-address "Foo" "Paris" "France")))))))
+
+ (pass-if "set-fields with unknown first getter"
+ (let ()
+ (define-immutable-record-type foo (make-foo x) foo?
+ (x foo-x)
+ (y foo-y set-foo-y)
+ (z foo-z set-foo-z))
+
+ (define-immutable-record-type :bar (make-bar i j) bar?
+ (i bar-i)
+ (j bar-j set-bar-j))
+
+ (catch 'syntax-error
+ (lambda ()
+ (compile '(let ((s (make-bar (make-foo 5) 2)))
+ (set-fields s ((bar-i foo-x) 1) ((blah) 3)))
+ #:env (current-module))
+ #f)
+ (lambda (key whom what src form subform)
+ (equal? (list key whom what form subform)
+ '(syntax-error set-fields "unknown getter"
+ (set-fields s ((bar-i foo-x) 1) ((blah) 3))
+ blah))))))
+
+ (pass-if "set-fields with unknown second getter"
+ (let ()
+ (define-immutable-record-type foo (make-foo x) foo?
+ (x foo-x)
+ (y foo-y set-foo-y)
+ (z foo-z set-foo-z))
+
+ (define-immutable-record-type :bar (make-bar i j) bar?
+ (i bar-i)
+ (j bar-j set-bar-j))
+
+ (catch 'syntax-error
+ (lambda ()
+ (compile '(let ((s (make-bar (make-foo 5) 2)))
+ (set-fields s ((bar-i foo-x) 1) ((blah) 3)))
+ #:env (current-module))
+ #f)
+ (lambda (key whom what src form subform)
+ (equal? (list key whom what form subform)
+ '(syntax-error set-fields "unknown getter"
+ (set-fields s ((bar-i foo-x) 1) ((blah) 3))
+ blah))))))
+
+ (pass-if "set-fields with duplicate field path"
+ (let ()
+ (define-immutable-record-type foo (make-foo x) foo?
+ (x foo-x)
+ (y foo-y set-foo-y)
+ (z foo-z set-foo-z))
+
+ (define-immutable-record-type :bar (make-bar i j) bar?
+ (i bar-i)
+ (j bar-j set-bar-j))
+
+ (catch 'syntax-error
+ (lambda ()
+ (compile '(let ((s (make-bar (make-foo 5) 2)))
+ (set-fields s
+ ((bar-i foo-x) 1)
+ ((bar-i foo-z) 2)
+ ((bar-i foo-x) 3)))
+ #:env (current-module))
+ #f)
+ (lambda (key whom what src form subform)
+ (equal? (list key whom what form subform)
+ '(syntax-error set-fields "duplicate field path"
+ (set-fields s
+ ((bar-i foo-x) 1)
+ ((bar-i foo-z) 2)
+ ((bar-i foo-x) 3))
+ (bar-i foo-x)))))))
+
+ (pass-if "set-fields with one path as a prefix of another"
+ (let ()
+ (define-immutable-record-type foo (make-foo x) foo?
+ (x foo-x)
+ (y foo-y set-foo-y)
+ (z foo-z set-foo-z))
+
+ (define-immutable-record-type :bar (make-bar i j) bar?
+ (i bar-i)
+ (j bar-j set-bar-j))
+
+ (catch 'syntax-error
+ (lambda ()
+ (compile '(let ((s (make-bar (make-foo 5) 2)))
+ (set-fields s
+ ((bar-i foo-x) 1)
+ ((bar-i foo-z) 2)
+ ((bar-i) 3)))
+ #:env (current-module))
+ #f)
+ (lambda (key whom what src form subform)
+ (equal? (list key whom what form subform)
+ '(syntax-error set-fields
+ "one field path is a prefix of another"
+ (set-fields s
+ ((bar-i foo-x) 1)
+ ((bar-i foo-z) 2)
+ ((bar-i) 3))
+ (bar-i)))))))))
(with-test-prefix "record compatibility"
@@ -119,3 +602,8 @@
(pass-if "record-constructor"
(equal? ((record-constructor :foo) 1)
(make-foo 1))))
+
+;;; Local Variables:
+;;; mode: scheme
+;;; eval: (put 'set-fields 'scheme-indent-function 1)
+;;; End:
--
1.7.10.4
^ permalink raw reply related [flat|nested] 22+ messages in thread
* Re: Functional record "setters", a different approach
2012-11-08 5:15 ` Mark H Weaver
@ 2012-11-08 19:09 ` Ludovic Courtès
2012-11-09 3:54 ` Mark H Weaver
2012-11-10 4:13 ` Mark H Weaver
0 siblings, 2 replies; 22+ messages in thread
From: Ludovic Courtès @ 2012-11-08 19:09 UTC (permalink / raw)
To: guile-devel
Hi Mark!
Mark H Weaver <mhw@netris.org> skribis:
> I've attached a slightly improved functional record "setters" patch.
> The only change since yesterday's version is to the test suite, which
> now includes tests of the compile-time error checking.
Nice, thanks!
It addresses my main concern with the previous version of the patch,
which is that it lacked support for named setters, so that’s great.
At the time you were concerned about the “weight” of these macros. Are
you just more relaxed now, or do you have a psyntax optimization in the
pipeline? :-)
> + (make-address "Foo" "Paris" "France"))))
> + (and (equal? (set-fields p
> + ((person-email) "bar@example.com")
> + ((person-address address-country) "Spain")
> + ((person-address address-city) "Barcelona"))
The choice of towns seems inaccurate. ;-)
> + (pass-if "set-fields with one path as a prefix of another"
> + (let ()
> + (define-immutable-record-type foo (make-foo x) foo?
> + (x foo-x)
> + (y foo-y set-foo-y)
> + (z foo-z set-foo-z))
> +
> + (define-immutable-record-type :bar (make-bar i j) bar?
> + (i bar-i)
> + (j bar-j set-bar-j))
> +
> + (catch 'syntax-error
> + (lambda ()
> + (compile '(let ((s (make-bar (make-foo 5) 2)))
> + (set-fields s
> + ((bar-i foo-x) 1)
> + ((bar-i foo-z) 2)
> + ((bar-i) 3)))
> + #:env (current-module))
> + #f)
> + (lambda (key whom what src form subform)
> + (equal? (list key whom what form subform)
> + '(syntax-error set-fields
> + "one field path is a prefix of another"
> + (set-fields s
> + ((bar-i foo-x) 1)
> + ((bar-i foo-z) 2)
> + ((bar-i) 3))
> + (bar-i)))))))))
You might want to use ‘pass-if-equal’ here, for better reporting.
Please commit, I’ll take care of the doc.
Thanks!
Ludo’.
^ permalink raw reply [flat|nested] 22+ messages in thread
* Re: Functional record "setters", a different approach
2012-11-08 19:09 ` Ludovic Courtès
@ 2012-11-09 3:54 ` Mark H Weaver
2012-11-10 16:28 ` Ludovic Courtès
2012-11-10 4:13 ` Mark H Weaver
1 sibling, 1 reply; 22+ messages in thread
From: Mark H Weaver @ 2012-11-09 3:54 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: guile-devel
Hi Ludovic!
ludo@gnu.org (Ludovic Courtès) writes:
> At the time you were concerned about the “weight” of these macros. Are
> you just more relaxed now, or do you have a psyntax optimization in the
> pipeline? :-)
I did some experiments, and on my 64-bit system this patch increases the
bytecode associated with a record type definition by about 2755 bytes
plus 852 bytes per field. I can live with that.
>> + (and (equal? (set-fields p
>> + ((person-email) "bar@example.com")
>> + ((person-address address-country) "Spain")
>> + ((person-address address-city) "Barcelona"))
>
> The choice of towns seems inaccurate. ;-)
Heh, good point. I changed "Spain" to "Catalonia" :)
>> + (pass-if "set-fields with one path as a prefix of another"
>> + (let ()
>> + (define-immutable-record-type foo (make-foo x) foo?
>> + (x foo-x)
>> + (y foo-y set-foo-y)
>> + (z foo-z set-foo-z))
>> +
>> + (define-immutable-record-type :bar (make-bar i j) bar?
>> + (i bar-i)
>> + (j bar-j set-bar-j))
>> +
>> + (catch 'syntax-error
>> + (lambda ()
>> + (compile '(let ((s (make-bar (make-foo 5) 2)))
>> + (set-fields s
>> + ((bar-i foo-x) 1)
>> + ((bar-i foo-z) 2)
>> + ((bar-i) 3)))
>> + #:env (current-module))
>> + #f)
>> + (lambda (key whom what src form subform)
>> + (equal? (list key whom what form subform)
>> + '(syntax-error set-fields
>> + "one field path is a prefix of another"
>> + (set-fields s
>> + ((bar-i foo-x) 1)
>> + ((bar-i foo-z) 2)
>> + ((bar-i) 3))
>> + (bar-i)))))))))
>
> You might want to use ‘pass-if-equal’ here, for better reporting.
'pass-if-equal' seems inapplicable here, since I'm testing for an
exception. 'pass-if-exception' was closer to what I needed, but I
wanted to verify more than just the exception key.
> Please commit, I’ll take care of the doc.
Done, and thanks :)
Mark
^ permalink raw reply [flat|nested] 22+ messages in thread
* Re: Functional record "setters", a different approach
2012-11-08 19:09 ` Ludovic Courtès
2012-11-09 3:54 ` Mark H Weaver
@ 2012-11-10 4:13 ` Mark H Weaver
1 sibling, 0 replies; 22+ messages in thread
From: Mark H Weaver @ 2012-11-10 4:13 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: guile-devel
Hi Ludovic,
ludo@gnu.org (Ludovic Courtès) writes:
> Mark H Weaver <mhw@netris.org> skribis:
>> + (pass-if "set-fields with one path as a prefix of another"
>> + (let ()
>> + (define-immutable-record-type foo (make-foo x) foo?
>> + (x foo-x)
>> + (y foo-y set-foo-y)
>> + (z foo-z set-foo-z))
>> +
>> + (define-immutable-record-type :bar (make-bar i j) bar?
>> + (i bar-i)
>> + (j bar-j set-bar-j))
>> +
>> + (catch 'syntax-error
>> + (lambda ()
>> + (compile '(let ((s (make-bar (make-foo 5) 2)))
>> + (set-fields s
>> + ((bar-i foo-x) 1)
>> + ((bar-i foo-z) 2)
>> + ((bar-i) 3)))
>> + #:env (current-module))
>> + #f)
>> + (lambda (key whom what src form subform)
>> + (equal? (list key whom what form subform)
>> + '(syntax-error set-fields
>> + "one field path is a prefix of another"
>> + (set-fields s
>> + ((bar-i foo-x) 1)
>> + ((bar-i foo-z) 2)
>> + ((bar-i) 3))
>> + (bar-i)))))))))
>
> You might want to use ‘pass-if-equal’ here, for better reporting.
I see now what you meant, and I just pushed a patch to convert these to
use 'pass-if-equal'.
I also pushed a couple more patches to improve error reporting.
Thanks!
Mark
^ permalink raw reply [flat|nested] 22+ messages in thread
* Re: Functional record "setters", a different approach
2012-11-09 3:54 ` Mark H Weaver
@ 2012-11-10 16:28 ` Ludovic Courtès
2012-11-10 19:03 ` Mark H Weaver
0 siblings, 1 reply; 22+ messages in thread
From: Ludovic Courtès @ 2012-11-10 16:28 UTC (permalink / raw)
To: guile-devel
[-- Attachment #1: Type: text/plain, Size: 170 bytes --]
Hello!
Documentation attached. Comments?
BTW, why does ‘set-field’ has the record as its 2nd argument instead of
1st (unlike ‘set-fields’)?
Thanks,
Ludo’.
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: the patch --]
[-- Type: text/x-patch, Size: 4474 bytes --]
From f7877d47009dc85e74bc63fd562b77f552a54bd6 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Sat, 10 Nov 2012 17:27:14 +0100
Subject: [PATCH] doc: Document SRFI-9 functional setters.
* doc/ref/api-compound.texi (Functional ``Setters''): New section.
---
doc/ref/api-compound.texi | 101 +++++++++++++++++++++++++++++++++++++++++++++
1 file changed, 101 insertions(+)
diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi
index b3fe0bd..0451368 100644
--- a/doc/ref/api-compound.texi
+++ b/doc/ref/api-compound.texi
@@ -2398,6 +2398,107 @@ This example prints the employee's name in brackets, for instance @code{[Fred]}.
(write-char #\] port)))
@end example
+@unnumberedsubsubsec Functional ``Setters''
+
+@cindex functional setters
+
+When writing code in a functional style, it is desirable to never alter
+the contents of records. For such code, a simple way to return new
+record instances based on existing ones is highly desirable.
+
+The @code{(srfi srfi-9 gnu)} module extends SRFI-9 with facilities to
+return new record instances based on existing ones, only with one or
+more field values changed---@dfn{functional setters}. First, the
+@code{define-immutable-record-type} works like
+@code{define-record-type}, except that setters are defined as functional
+setters.
+
+@deffn {Scheme Syntax} define-immutable-record-type type @* (constructor fieldname @dots{}) @* predicate @* (fieldname accessor [modifier]) @dots{}
+Define @var{type} as a new record type, like @code{define-record-type}.
+However, the record type is made @emph{immutable} (records may not be
+mutated, even with @code{struct-set!}), and any @var{modifier} is
+defined to be a functional setter---a procedure that returns a new
+record instance with the specified field changed, and leaves the
+original unchanged (see example below.)
+@end deffn
+
+@noindent
+In addition, the generic @code{set-field} and @code{set-fields} macros
+may be applied to any SRFI-9 record.
+
+@deffn {Scheme Syntax} set-field (field sub-fields ...) record value
+Return a new record of @var{record}'s type whose fields are equal to
+the corresponding fields of @var{record} except for the one specified by
+@var{field}.
+
+@var{field} must be the name of the getter corresponding to the field of
+@var{record} being ``set''. Subsequent @var{sub-fields} must be record
+getters designating sub-fields within that field value to be set (see
+example below.)
+@end deffn
+
+@deffn {Scheme Syntax} set-fields record ((field sub-fields ...) value) ...
+Like @code{set-field}, but can be used to set more than one field at a
+time. This expands to code that is more efficient than a series of
+single @code{set-field} calls.
+@end deffn
+
+To illustrate the use of functional setters, let's assume these two
+record type definitions:
+
+@example
+(define-record-type <address>
+ (address street city country)
+ address?
+ (street address-street)
+ (city address-city)
+ (country address-country))
+
+(define-immutable-record-type <person>
+ (person age email address)
+ person?
+ (age person-age set-person-age)
+ (email person-email set-person-email)
+ (address person-address set-person-address))
+@end example
+
+@noindent
+First, note that the @code{<person>} record type definition introduces
+named functional setters. These may be used like this:
+
+@example
+(define fsf-address
+ (address "Franklin Street" "Boston" "USA"))
+
+(define rms
+ (person 30 "rms@@gnu.org" fsf-address))
+
+(and (equal? (set-person-age rms 60)
+ (person 60 "rms@@gnu.org" fsf-address))
+ (= (person-age rms) 30))
+@result{} #t
+@end example
+
+@noindent
+Here, the original @code{<person>} record, to which @var{rms} is bound,
+is left unchanged.
+
+Now, suppose we want to change both the street and age of @var{rms}.
+This can be achieved using @code{set-fields}:
+
+@example
+(set-fields rms
+ ((person-age) 60)
+ ((person-address address-street) "Temple Place"))
+@result{} #<<person> age: 60 email: "rms@@gnu.org"
+ address: #<<address> street: "Temple Place" city: "Boston" country: "USA">>
+@end example
+
+@noindent
+Notice how the above changed two fields of @var{rms}, including the
+@code{street} field of its @code{address} field, in a concise way. Also
+note that @code{set-fields} works equally well for types defined with
+just @code{define-record-type}.
@node Records
@subsection Records
--
1.7.10.4
^ permalink raw reply related [flat|nested] 22+ messages in thread
* Re: Functional record "setters", a different approach
2012-11-10 16:28 ` Ludovic Courtès
@ 2012-11-10 19:03 ` Mark H Weaver
2012-11-10 21:40 ` Ludovic Courtès
0 siblings, 1 reply; 22+ messages in thread
From: Mark H Weaver @ 2012-11-10 19:03 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: guile-devel
Hi Ludovic,
ludo@gnu.org (Ludovic Courtès) writes:
> Documentation attached. Comments?
Thanks! Looks good to me, modulo a few comments below.
> BTW, why does ‘set-field’ has the record as its 2nd argument instead of
> 1st (unlike ‘set-fields’)?
Good question. I followed the syntax of 'set-field' from your original
patch, but that argument order did not make sense for 'set-fields'.
On one hand, (set-field (person-address address-city) person "Boston")
matches the order of the corresponding english "set the field
(person-address address-city) of person to Boston", and thus reads a bit
more naturally to my ears.
On the other hand, it would be good for the two syntaxes to be
consistent with each other, and (set-field <record> <field> <value>)
would also be more consistent with things like 'hash-set!',
'vector-set!', etc.
Honestly, I could go either way. If you think it makes sense to change
the order to (set-field <record> <field> <value>), I'd be glad to make
that change. Obviously it's now or never :)
> +@unnumberedsubsubsec Functional ``Setters''
> +
> +@cindex functional setters
> +
> +When writing code in a functional style, it is desirable to never alter
> +the contents of records. For such code, a simple way to return new
> +record instances based on existing ones is highly desirable.
> +
> +The @code{(srfi srfi-9 gnu)} module extends SRFI-9 with facilities to
> +return new record instances based on existing ones, only with one or
> +more field values changed---@dfn{functional setters}. First, the
> +@code{define-immutable-record-type} works like
> +@code{define-record-type}, except that setters are defined as functional
> +setters.
"except that the fields are immutable and the setters are ..."
[...]
> +@deffn {Scheme Syntax} set-field (field sub-fields ...) record value
> +Return a new record of @var{record}'s type whose fields are equal to
> +the corresponding fields of @var{record} except for the one specified by
> +@var{field}.
> +
> +@var{field} must be the name of the getter corresponding to the field of
> +@var{record} being ``set''. Subsequent @var{sub-fields} must be record
This is the first time that "getter" is used, but it has not been made
clear that you mean what has been called an "accessor" elsewhere in the
doc. More generally, there is a confusing mixture of the
accessor/modifier and getter/setter terminology. I wonder if it would
made sense to do some kind of find/replace in this section.
Other than that, it looks great, thanks!
Mark
^ permalink raw reply [flat|nested] 22+ messages in thread
* Re: Functional record "setters", a different approach
2012-11-10 19:03 ` Mark H Weaver
@ 2012-11-10 21:40 ` Ludovic Courtès
0 siblings, 0 replies; 22+ messages in thread
From: Ludovic Courtès @ 2012-11-10 21:40 UTC (permalink / raw)
To: Mark H Weaver; +Cc: guile-devel
Mark H Weaver <mhw@netris.org> skribis:
> ludo@gnu.org (Ludovic Courtès) writes:
[...]
>> BTW, why does ‘set-field’ has the record as its 2nd argument instead of
>> 1st (unlike ‘set-fields’)?
>
> Good question. I followed the syntax of 'set-field' from your original
> patch, but that argument order did not make sense for 'set-fields'.
In the meantime we concurred on IRC that keeping the record as the first
argument in both cases may be best.
>> +The @code{(srfi srfi-9 gnu)} module extends SRFI-9 with facilities to
>> +return new record instances based on existing ones, only with one or
>> +more field values changed---@dfn{functional setters}. First, the
>> +@code{define-immutable-record-type} works like
>> +@code{define-record-type}, except that setters are defined as functional
>> +setters.
>
> "except that the fields are immutable and the setters are ..."
OK.
>> +@deffn {Scheme Syntax} set-field (field sub-fields ...) record value
>> +Return a new record of @var{record}'s type whose fields are equal to
>> +the corresponding fields of @var{record} except for the one specified by
>> +@var{field}.
>> +
>> +@var{field} must be the name of the getter corresponding to the field of
>> +@var{record} being ``set''. Subsequent @var{sub-fields} must be record
>
> This is the first time that "getter" is used, but it has not been made
> clear that you mean what has been called an "accessor" elsewhere in the
> doc. More generally, there is a confusing mixture of the
> accessor/modifier and getter/setter terminology. I wonder if it would
> made sense to do some kind of find/replace in this section.
Yeah. I ended up leaving “getter”, because that’s the term used in the
SRFI-9 node from the beginning. But I agree we might need to do some
find/replace at some point.
Ludo’.
^ permalink raw reply [flat|nested] 22+ messages in thread
end of thread, other threads:[~2012-11-10 21:40 UTC | newest]
Thread overview: 22+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2012-04-11 6:59 Functional record "setters", a different approach Mark H Weaver
2012-04-11 7:57 ` Mark H Weaver
2012-04-11 8:20 ` Mark H Weaver
2012-04-11 22:27 ` Ludovic Courtès
2012-04-11 22:22 ` Ludovic Courtès
2012-04-12 15:04 ` Mark H Weaver
2012-04-12 16:45 ` Thien-Thi Nguyen
2012-04-12 19:58 ` Ludovic Courtès
2012-04-13 1:58 ` Mark H Weaver
2012-04-13 15:41 ` Ludovic Courtès
2012-04-13 17:26 ` Mark H Weaver
2012-05-07 16:34 ` Ludovic Courtès
2012-05-14 22:25 ` Mark H Weaver
2012-05-15 21:23 ` Ludovic Courtès
2012-11-07 20:04 ` Mark H Weaver
2012-11-08 5:15 ` Mark H Weaver
2012-11-08 19:09 ` Ludovic Courtès
2012-11-09 3:54 ` Mark H Weaver
2012-11-10 16:28 ` Ludovic Courtès
2012-11-10 19:03 ` Mark H Weaver
2012-11-10 21:40 ` Ludovic Courtès
2012-11-10 4:13 ` Mark H Weaver
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).