[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: Functional record "setters", a different approach
|
From: |
Mark H Weaver |
|
Subject: |
Re: Functional record "setters", a different approach |
|
Date: |
Thu, 08 Nov 2012 00:15:43 -0500 |
|
User-agent: |
Gnus/5.13 (Gnus v5.13) Emacs/24.2 (gnu/linux) |
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 "address@hidden"
(make-address "Foo" "Paris")))
p
=> #<person age: 30 email: "address@hidden"
address: #<address street: "Foo" city: "Paris">>
(set-field (person-address address-city) p "Düsseldorf")
=> #<person age: 30 email: "address@hidden"
address: #<address street: "Foo" city: "Düsseldorf">>
p
=> #<person age: 30 email: "address@hidden"
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) "address@hidden")
((person-address address-city) "Düsseldorf"))
=> #<person age: 30 email: "address@hidden"
address: #<address street: "Foo" city: "Düsseldorf">>
(define p2 (set-fields p
((person-age) 20)
((person-email) "address@hidden")))
p2
=> #<person age: 20 email: "address@hidden"
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
>From 274c795382308f537aea620c3972cff291624cce Mon Sep 17 00:00:00 2001
From: Mark H Weaver <address@hidden>
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 <address@hidden>
* 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))))))))
+
+
+(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 "address@hidden"
+ (make-address "Foo" "Paris" "France"))))
+ (and (equal? (set-field (person-address address-street) p "Bar")
+ (make-person 30 "address@hidden"
+ (make-address "Bar" "Paris" "France")))
+ (equal? (set-field (person-email) p "address@hidden")
+ (make-person 30 "address@hidden"
+ (make-address "Foo" "Paris" "France")))
+ (equal? p (make-person 30 "address@hidden"
+ (make-address "Foo" "Paris" "France"))))))
+
+ (pass-if "set-fields"
+ (let ((p (make-person 30 "address@hidden"
+ (make-address "Foo" "Paris" "France"))))
+ (and (equal? (set-fields p
+ ((person-email) "address@hidden")
+ ((person-address address-country) "Spain")
+ ((person-address address-city) "Barcelona"))
+ (make-person 30 "address@hidden"
+ (make-address "Foo" "Barcelona" "Spain")))
+ (equal? (set-fields p
+ ((person-email) "address@hidden")
+ ((person-age) 20))
+ (make-person 20 "address@hidden"
+ (make-address "Foo" "Paris" "France")))
+ (equal? p (make-person 30 "address@hidden"
+ (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 "address@hidden"
+ (make-address "Foo" "Paris" "France"))))
+ (and (equal? (set-field (person-address address-street) p "Bar")
+ (make-person 30 "address@hidden"
+ (make-address "Bar" "Paris" "France")))
+ (equal? (set-field (person-email) p "address@hidden")
+ (make-person 30 "address@hidden"
+ (make-address "Foo" "Paris" "France")))
+ (equal? p (make-person 30 "address@hidden"
+ (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 "address@hidden"
+ (make-address "Foo" "Paris" "France"))))
+ (and (equal? (set-fields p
+ ((person-email) "address@hidden")
+ ((person-address address-country) "Spain")
+ ((person-address address-city) "Barcelona"))
+ (make-person 30 "address@hidden"
+ (make-address "Foo" "Barcelona" "Spain")))
+ (equal? (set-fields p
+ ((person-email) "address@hidden")
+ ((person-age) 20))
+ (make-person 20 "address@hidden"
+ (make-address "Foo" "Paris" "France")))
+ (equal? p (make-person 30 "address@hidden"
+ (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
- Re: Functional record "setters", a different approach, Mark H Weaver, 2012/11/07
- Re: Functional record "setters", a different approach,
Mark H Weaver <=
- Re: Functional record "setters", a different approach, Ludovic Courtès, 2012/11/08
- Re: Functional record "setters", a different approach, Mark H Weaver, 2012/11/08
- Re: Functional record "setters", a different approach, Ludovic Courtès, 2012/11/10
- Re: Functional record "setters", a different approach, Mark H Weaver, 2012/11/10
- Re: Functional record "setters", a different approach, Ludovic Courtès, 2012/11/10
- Re: Functional record "setters", a different approach, Mark H Weaver, 2012/11/09