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 +++++++++++++++++++++++++++++---------
 1 file changed, 29 insertions(+), 9 deletions(-)

(limited to 'src/guile')

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"
-- 
cgit v1.2.3