From 4572f8ae1319af0b6d315399794a5fe9fea7a6fc Mon Sep 17 00:00:00 2001
From: Wojtek Kosior <koszko@koszko.org>
Date: Wed, 13 Dec 2023 19:26:46 +0100
Subject: Add syntax for field updaters.

You can now do

    (define-immutable-record-type* my-record (counter #:default 0))

    (define old-record (my-record (counter 1)))

    (my-record #:<- old-record (counter #:=> 1+))

or

    (my-record #:<- old-record (counter #:-> (1+ counter)))
---
 src/guile/de-paul-records.scm        | 38 +++++++++++++++++++++++++++---------
 tests/guile/de-paul-records-test.scm | 14 ++++++-------
 2 files changed, 36 insertions(+), 16 deletions(-)

diff --git a/src/guile/de-paul-records.scm b/src/guile/de-paul-records.scm
index 57d65e5..4b4e91b 100644
--- a/src/guile/de-paul-records.scm
+++ b/src/guile/de-paul-records.scm
@@ -107,8 +107,8 @@
                   #'args-rest)))))))
 
   (define-immutable-record-type <field-init> (make-field-init) field-init?
-    (name       field-init-name       field-init-set-name)
-    (value-expr field-init-value-expr field-init-set-value-expr))
+    (name            field-init-name            field-init-set-name)
+    (make-value-expr field-init-make-value-expr field-init-set-make-value-expr))
 
   (define %null-field-init
     (make-field-init))
@@ -119,10 +119,28 @@
        (identifier? #'field-name)
        (set-fields %null-field-init
          ((field-init-name) #'field-name)
-         ((field-init-value-expr) #'value-expr)))
+         ((field-init-make-value-expr) (const #'value-expr))))
+
       (field-name
        (identifier? #'field-name)
-       (syntax->field-init #'(field-name field-name)))))
+       (syntax->field-init #'(field-name field-name)))
+
+      ((field-name #:=> value-update-proc)
+       (identifier? #'field-name)
+       (set-fields %null-field-init
+         ((field-init-name) #'field-name)
+         ((field-init-make-value-expr)
+          (lambda (record-name record-base)
+            #`(value-update-proc
+               (#,(format-identifiers "~a-~a" record-name #'field-name)
+                #,record-base))))))
+
+      ((field-name #:-> value-update-expr)
+       (identifier? #'field-name)
+       (syntax->field-init #'(field-name #:=> (lambda (field-name)
+                                                value-update-expr))))))
+
+
 
   (define-immutable-record-type <record-init> (make-record-init) record-init?
     (inherit record-init-inherit record-init-set-inherit)
@@ -156,12 +174,14 @@
     (match init-form
       ((= syntax->record-init (and (= record-init-inherit inherit)
                                    (= record-init-fields  field-inits)))
-       #`(let* (#,@(map (match-lambda
-                          ((and (= field-init-name       field-name)
-                                (= field-init-value-expr value-expr))
-                           #`(#,field-name #,value-expr)))
+       #`(let* ((base #,(or inherit %null-record))
+                #,@(map (match-lambda
+                          ((and (= field-init-name            field-name)
+                                (= field-init-make-value-expr make-value-expr))
+                           #`(#,field-name
+                              #,(make-value-expr record-name #'base))))
                         field-inits))
-           (set-fields #,(or inherit %null-record)
+           (set-fields base
              #,@(map (match-lambda
                        ((= field-init-name field-name)
                         #`((#,(format-identifiers "~a-~a"
diff --git a/tests/guile/de-paul-records-test.scm b/tests/guile/de-paul-records-test.scm
index d8970a4..95d1cb3 100644
--- a/tests/guile/de-paul-records-test.scm
+++ b/tests/guile/de-paul-records-test.scm
@@ -74,23 +74,23 @@
                              (list 'iss? iss? 'is? is?)))
                          (test-env 'lisp))))
 
-  (test-group "lisp paren-3002"
+  (test-group "lisp paren-3001.1"
     (tu:test-equal '#t
                    (eval
                     '(begin
-                       (define %paren-3002
+                       (define %paren-3001.1
                          (lisp #:<- %paren-3001
-                               (name "paren-3002")
+                               (name #:-> (string-append name ".1"))
                                (is-syntactically-scoped? #t)))
 
-                       (match `(a . ,%paren-3002)
+                       (match `(a . ,%paren-3001.1)
                          (`(a . ,($* lisp is-syntactically-scoped?))
                           is-syntactically-scoped?)))
                     (test-env 'lisp)))
 
-    (tu:test-equal '(#f "paren-3002")
+    (tu:test-equal '(#f "paren-3001.1")
                    (eval
-                    '(match (vector %paren-3002)
+                    '(match (vector %paren-3001.1)
                        (#(($* lisp is-scheme? name))
                         (list is-scheme? name)))
                     (test-env 'lisp))))
@@ -122,7 +122,7 @@
                          ;; (*lisp ...) form is a "primitive" variant of the
                          ;; (lisp ...) form — it shall not call the finalizer.
                          (*lisp #:<- (lisp)
-                                (name "paren-3004")
+                                (name #:=> (const "paren-3004"))
                                 (is-scheme? #t)))
 
                        (match %paren-3004
-- 
cgit v1.2.3