From: ludo@gnu.org (Ludovic Courtès)
To: guile-devel@gnu.org
Subject: Functional record “setters”
Date: Mon, 09 Apr 2012 02:17:35 +0200 [thread overview]
Message-ID: <871unxhi74.fsf@gnu.org> (raw)
[-- Attachment #1: Type: text/plain, Size: 1685 bytes --]
Hi!
The attached patches do two things:
• The first one adds ‘define-immutable-record-type’ in (srfi srfi-9 gnu),
which works like this:
(define-immutable-record-type bar
(make-bar x y z)
bar?
(x bar-x set-bar-x)
(y bar-y set-bar-y))
(equal? (set-bar-y (make-bar 1 0) 2)
(make-bar 1 2))
=> #t
• The second one adds the ‘set-field’ macro, which allows fields
within nested records to be set:
(define-immutable-record-type address
(make-address street city)
address?
(street address-street)
(city address-city))
(define-immutable-record-type person
(make-person age address)
person?
(age person-age)
(address person-address))
(let ((p (make-person 30 (make-address "Foo" "Paris"))))
(set-field (person-address address-city) p "Düsseldorf"))
=> #<person age: 30 address: #<address street: "Foo" city: "Düsseldorf">>
(This was inspired by “Asymmetric Lenses in Scala”, by Tony Morris.)
The implementation uses a simple trick where macros such as
‘person-address’ conditionally accept a second argument to behave as
a functional setter; ‘set-field’ just sets a syntax parameter so
that this condition holds.
Currently there’s no type-checking: if the given fields are not
struct accessors, or are unbound, ‘set-field’ expansion takes place
anyway. Suggestions to improve this welcome!
I’d like to apply these patches and associated documentation in
stable-2.0. Thoughts?
Thanks,
Ludo’.
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: first patch --]
[-- Type: text/x-patch, Size: 11379 bytes --]
From e38914e1b70cfaa16d1f144268bb52d2fd3c83d8 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Sun, 8 Apr 2012 17:21:56 +0200
Subject: [PATCH 1/2] SRFI-9: Add `define-immutable-record-type' as an
extension.
* module/srfi/srfi-9.scm (define-record-type): Rename to...
(%define-record-type): ... this. Add `immutable?' parameter.
[accessors]: Wrap things in `(begin ...)' instead of using
`unsyntax-splicing'.
[copy-modifier, functional-accessors, record-layout]: New procedures.
(define-record-type): Define in terms of `%define-record-type'.
* module/srfi/srfi-9/gnu.scm (define-immutable-record-type): New macro.
* test-suite/tests/srfi-9.test ("define-immutable-record-type"): New
test prefix.
---
module/srfi/srfi-9.scm | 97 +++++++++++++++++++++++++++++++++---------
module/srfi/srfi-9/gnu.scm | 14 +++++-
test-suite/tests/srfi-9.test | 71 ++++++++++++++++++++++++++++++-
3 files changed, 157 insertions(+), 25 deletions(-)
diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm
index cb8dd0a..07b4afa 100644
--- a/module/srfi/srfi-9.scm
+++ b/module/srfi/srfi-9.scm
@@ -1,6 +1,6 @@
;;; srfi-9.scm --- define-record-type
-;; Copyright (C) 2001, 2002, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2002, 2006, 2009, 2010, 2011, 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
@@ -109,7 +109,7 @@
(loop (cdr fields) (+ 1 off)))))
(display ">" p))
-(define-syntax define-record-type
+(define-syntax %define-record-type
(lambda (x)
(define (field-identifiers field-specs)
(syntax-case field-specs ()
@@ -156,38 +156,86 @@
1+
0)))))))
+ (define (copy-modifier type-name field-count orig-record field-index
+ value)
+ ;; Produce code that returns a record identical to ORIG-RECORD,
+ ;; except that its field at FIELD-INDEX is set to VALUE.
+ #`(make-struct #,type-name 0
+ #,@(unfold (lambda (field-num)
+ (>= field-num field-count))
+ (lambda (field-num)
+ (if (= field-num field-index)
+ value
+ #`(struct-ref #,orig-record
+ #,field-num)))
+ 1+
+ 0)))
+
(define (accessors type-name field-specs indices)
(syntax-case field-specs ()
(()
- #'())
+ #'(begin))
((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)))))))
+ #`(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)))))))))
+ #`(begin
+ #,(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 ...)
+ #`(begin
+ #,(accessors type-name #'(field-spec) indices)
+ (begin #,(accessors type-name #'(rest ...) indices))))))
+
+ (define (functional-accessors type-name field-specs field-count indices)
+ (syntax-case field-specs ()
+ (()
+ #'(begin))
+ ((field-spec)
+ (syntax-case #'field-spec ()
+ ((name accessor)
+ (accessors type-name #'(field-spec) indices))
+ ((name accessor modifier)
+ (let ((index (assoc-ref indices (syntax->datum #'name))))
+ #`(begin
+ #,(functional-accessors type-name #'((name accessor))
+ field-count indices)
+ (define-inlinable (modifier s v)
+ #,(copy-modifier type-name field-count
+ #'s index #'v)))))))
((field-spec rest ...)
- #`(#,@(accessors type-name #'(field-spec) indices)
- #,@(accessors type-name #'(rest ...) indices)))))
+ #`(begin
+ #,(functional-accessors type-name #'(field-spec)
+ field-count indices)
+ (begin
+ #,(functional-accessors type-name #'(rest ...)
+ field-count indices))))))
+
+ (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 ...)
+ ((_ immutable? type-name constructor-spec predicate-name
+ field-spec ...)
+ (boolean? (syntax->datum #'immutable?))
(let* ((fields (field-identifiers #'(field-spec ...)))
(field-count (length fields))
- (layout (string-concatenate (make-list field-count "pw")))
+ (immutable? (syntax->datum #'immutable?))
+ (layout (record-layout immutable? field-count))
(indices (field-indices (map syntax->datum fields))))
#`(begin
(define type-name
@@ -205,6 +253,13 @@
#,(constructor #'type-name #'constructor-spec indices)
- #,@(accessors #'type-name #'(field-spec ...) indices)))))))
+ #,(if immutable?
+ (functional-accessors #'type-name #'(field-spec ...)
+ (length #'(field-spec ...))
+ indices)
+ (accessors #'type-name #'(field-spec ...) indices))))))))
+
+(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..e8f424c 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,18 @@
;;; Code:
(define-module (srfi srfi-9 gnu)
- #:export (set-record-type-printer!))
+ #:use-module (srfi srfi-9)
+ #:export (set-record-type-printer!
+ define-immutable-record-type))
(define (set-record-type-printer! type thunk)
"Set a custom printer THUNK for TYPE."
(struct-set! type vtable-index-printer thunk))
+
+;; Import (srfi srfi-9)'s private module, so we can use the private
+;; `%define-record-type' macro.
+(eval-when (compile eval load)
+ (module-use! (current-module) (resolve-module '(srfi srfi-9))))
+
+(define-syntax-rule (define-immutable-record-type name ctor pred fields ...)
+ (%define-record-type #t name ctor pred fields ...))
diff --git a/test-suite/tests/srfi-9.test b/test-suite/tests/srfi-9.test
index f26a7a2..18082e2 100644
--- a/test-suite/tests/srfi-9.test
+++ b/test-suite/tests/srfi-9.test
@@ -1,7 +1,7 @@
;;;; srfi-9.test --- Test suite for Guile's SRFI-9 functions. -*- scheme -*-
;;;; Martin Grabmueller, 2001-05-10
;;;;
-;;;; Copyright (C) 2001, 2006, 2007, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2006, 2007, 2010, 2011, 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
@@ -20,7 +20,9 @@
(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?)
@@ -110,3 +112,68 @@
(let ((frotz (make-frotz 1 2)))
(and (= (frotz-a frotz) 1)
(= (frotz-b frotz) 2)))))
+
+\f
+(with-test-prefix "define-immutable-record-type"
+
+ (pass-if "get"
+ (let ()
+ (define-immutable-record-type bar
+ (make-bar x y z)
+ bar?
+ (x bar-x)
+ (y bar-y)
+ (z 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))
+
+ (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))))))
--
1.7.6
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: second patch --]
[-- Type: text/x-patch, Size: 6672 bytes --]
From e86dcb7662a2d75f1d9d683fc31fc5f39734f561 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Mon, 9 Apr 2012 01:41:03 +0200
Subject: [PATCH 2/2] SRFI-9: Add `set-field' as an extension.
* module/srfi/srfi-9.scm (make-procedure-name): New procedure, formerly
in `define-inlinable'.
(%reveal-setter): New syntax parameter.
(%define-record-type)[functional-accessors]: Mimic `define-inlinable',
but add support for (ACCESSOR obj val), when `%reveal-setter' allows
it.
* test-suite/tests/srfi-9.test ("set-field"): New test prefix.
---
module/srfi/srfi-9.scm | 48 ++++++++++++++++++++++++++++++++++++-----
module/srfi/srfi-9/gnu.scm | 18 ++++++++++++++-
test-suite/tests/srfi-9.test | 42 ++++++++++++++++++++++++++++++++++++
3 files changed, 101 insertions(+), 7 deletions(-)
diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm
index 07b4afa..3b12105 100644
--- a/module/srfi/srfi-9.scm
+++ b/module/srfi/srfi-9.scm
@@ -69,13 +69,13 @@
;; 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 (make-procedure-name name)
+ (datum->syntax name
+ (symbol-append '% (syntax->datum name)
+ '-procedure)))
+
(define-syntax define-inlinable
(lambda (x)
- (define (make-procedure-name name)
- (datum->syntax name
- (symbol-append '% (syntax->datum name)
- '-procedure)))
-
(syntax-case x ()
((_ (name formals ...) body ...)
(identifier? #'name)
@@ -109,6 +109,12 @@
(loop (cdr fields) (+ 1 off)))))
(display ">" p))
+;; Internal parameter used to tell immutable record accessor macros to
+;; behave as functional setters when called as (ACCESSOR obj val).
+(define-syntax-parameter %reveal-setter
+ (lambda (s)
+ (error "form only allowed within `set-field'" (syntax->datum s))))
+
(define-syntax %define-record-type
(lambda (x)
(define (field-identifiers field-specs)
@@ -207,7 +213,37 @@
((field-spec)
(syntax-case #'field-spec ()
((name accessor)
- (accessors type-name #'(field-spec) indices))
+ (let ((index (assoc-ref indices (syntax->datum #'name))))
+ (with-syntax ((proc-name (make-procedure-name #'name))
+ (index (datum->syntax #'name index)))
+ ;; Mimic `(define-inlinable (accessor s) ...)', but also
+ ;; allow the (ACCESSOR obj val) form.
+ #`(begin
+ (define (proc-name 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))))
+ (define-syntax accessor
+ (lambda (s)
+ (syntax-case s ()
+ ((_ 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))))
+ ((_ s v)
+ ;; Behave like a functional setter if
+ ;; %REVEAL-SETTER permits it.
+ #'(%reveal-setter
+ #,(copy-modifier type-name field-count
+ #'s (syntax->datum #'index)
+ #'v)))
+ (_
+ (identifier? s)
+ #'proc-name))))))))
((name accessor modifier)
(let ((index (assoc-ref indices (syntax->datum #'name))))
#`(begin
diff --git a/module/srfi/srfi-9/gnu.scm b/module/srfi/srfi-9/gnu.scm
index e8f424c..30845e6 100644
--- a/module/srfi/srfi-9/gnu.scm
+++ b/module/srfi/srfi-9/gnu.scm
@@ -25,7 +25,8 @@
(define-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-9)
#:export (set-record-type-printer!
- define-immutable-record-type))
+ define-immutable-record-type
+ set-field))
(define (set-record-type-printer! type thunk)
"Set a custom printer THUNK for TYPE."
@@ -38,3 +39,18 @@
(define-syntax-rule (define-immutable-record-type name ctor pred fields ...)
(%define-record-type #t name ctor pred fields ...))
+
+(define-syntax set-field
+ (lambda (s)
+ "Return a new object copied from OBJ, but with the given FIELDS set
+to VAL."
+ (syntax-case s ()
+ ((_ (f1 fields ...) obj val)
+ (identifier? #'f1)
+ #'(let ((r (set-field (fields ...) (f1 obj) val)))
+ (syntax-parameterize ((%reveal-setter
+ (syntax-rules ()
+ ((_ x) x))))
+ (f1 obj r))))
+ ((_ () obj val)
+ #'val))))
diff --git a/test-suite/tests/srfi-9.test b/test-suite/tests/srfi-9.test
index 18082e2..74bbcf2 100644
--- a/test-suite/tests/srfi-9.test
+++ b/test-suite/tests/srfi-9.test
@@ -177,3 +177,45 @@
(cut set-bar-y <> 2)
(cut set-bar-z <> 3))))
(equal? (set (make-bar 0 0 0)) (make-bar 1 2 3))))))
+
+\f
+(with-test-prefix "set-field"
+ (pass-if "one field"
+ (let ()
+ (define-immutable-record-type bar
+ (make-bar x y)
+ bar?
+ (x bar-x set-bar-x)
+ (y bar-y set-bar-y))
+
+ (equal? (set-field (bar-x) (make-bar 77 2) 1)
+ (make-bar 1 2))))
+
+ (pass-if "three fields"
+ (let ()
+ (define-immutable-record-type foo
+ (make-foo x y z)
+ foo?
+ (x foo-x)
+ (y foo-y)
+ (z foo-z))
+
+ (define-immutable-record-type bar
+ (make-bar xx yy)
+ bar?
+ (xx bar-x)
+ (yy bar-y))
+
+ (define-immutable-record-type baz
+ (make-baz a b)
+ baz?
+ (a baz-a)
+ (b baz-b))
+
+ (let ((s (make-foo 0 (make-bar (make-baz 1 2) 3) 4)))
+ (equal? (set-field (foo-y bar-x baz-b) s 222)
+ (make-foo 0 (make-bar (make-baz 1 222) 3) 4)))))
+
+ (pass-if-exception "field is not an identifier"
+ exception:syntax-pattern-unmatched
+ (compile '(set-field (1 2 3) s v) #:env (current-module))))
--
1.7.6
next reply other threads:[~2012-04-09 0:17 UTC|newest]
Thread overview: 9+ messages / expand[flat|nested] mbox.gz Atom feed top
2012-04-09 0:17 Ludovic Courtès [this message]
2012-04-09 18:55 ` Functional record “setters” Andy Wingo
2012-04-09 21:00 ` Ludovic Courtès
2012-04-10 1:19 ` Noah Lavine
2012-04-10 9:55 ` Ludovic Courtès
2012-04-10 14:18 ` Mark H Weaver
2012-04-10 14:27 ` Ludovic Courtès
2012-04-10 14:37 ` Noah Lavine
2012-04-10 15:15 ` Mark H Weaver
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/guile/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=871unxhi74.fsf@gnu.org \
--to=ludo@gnu.org \
--cc=guile-devel@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
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).