aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorWojtek Kosior <koszko@koszko.org>2023-12-13 19:26:46 +0100
committerWojtek Kosior <koszko@koszko.org>2023-12-13 19:26:46 +0100
commit4572f8ae1319af0b6d315399794a5fe9fea7a6fc (patch)
tree37dfba7ddc198b728e40a46c0927fc54559c4f43 /src
parent0309bc25938747c2570e560509644f1d71308006 (diff)
downloadde-paul-records-4572f8ae1319af0b6d315399794a5fe9fea7a6fc.tar.gz
de-paul-records-4572f8ae1319af0b6d315399794a5fe9fea7a6fc.zip
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)))
Diffstat (limited to 'src')
-rw-r--r--src/guile/de-paul-records.scm38
1 files changed, 29 insertions, 9 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"