Functional record “setters”

[Ludovic Courtès]

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’.

>From e38914e1b70cfaa16d1f144268bb52d2fd3c83d8 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <address@hidden>
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)))))
+
+
+(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

>From e86dcb7662a2d75f1d9d683fc31fc5f39734f561 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <address@hidden>
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))))))
+
+
+(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