From ffd0a028aefd203b4a42ded1e5a592e1b4d92dd7 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Mon, 4 Dec 2023 01:58:26 +0100
Subject: Complete rewrite of the lens system.

The old "lens" system was more of nested accessors. This rewrites them
to be much better, at the cost of some extra up-front complexity.

Beside the change in lenses, and all required adjustments, also adds
lens creation to the define-type macro.
---
 module/hnh/util/object.scm | 41 ++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 40 insertions(+), 1 deletion(-)

(limited to 'module/hnh/util/object.scm')

diff --git a/module/hnh/util/object.scm b/module/hnh/util/object.scm
index 813a59ce..68703e1e 100644
--- a/module/hnh/util/object.scm
+++ b/module/hnh/util/object.scm
@@ -112,11 +112,35 @@
                                   (datum->syntax stx))))
        #'(name name-get name-set)))))
 
+;;; Name of the created accessor
+(define (accessor-name field)
+  (syntax-case field ()
+    ((name kvs ...)
+     (cond ((kv-ref #'(kvs ...) accessor:)
+            => identity)
+           (else #'name)))
+    (name #'name)))
+
+;;; Name of the created lens
+(define (lens-name field)
+  (syntax-case field ()
+    ((name kvs ...)
+     (cond ((kv-ref #'(kvs ...) lens:)
+            => identity)
+           (else (->> (syntax->datum #'name)
+                      (format #f "~a*")
+                      string->symbol
+                      (datum->syntax field)))))
+    (name (->> (syntax->datum #'name)
+               (format #f "~a*")
+               string->symbol
+               (datum->syntax field)))))
+
 ;; Accessors are procedures for getting and setting fields in records
 (define-syntax (build-accessor stx)
   (syntax-case stx ()
     ((_ type-name (name kvs ...))
-     #'(define name
+     #`(define #,(accessor-name #'(name kvs ...))
          (case-lambda ((datum)
                        ((field-get type-name name) datum))
                       ((datum new-value)
@@ -126,10 +150,23 @@
                        ;; while keeping name bound to the accessor in the outer scope.
                        (let ((name new-value))
                          (validator name (name kvs ...)))
+
                        ((field-set type-name name) datum new-value)))))
+
     ((_ type-name name) #'(build-accessor type-name (name)))))
 
 
+(define (build-lenses stx fields)
+  (map (lambda (field)
+         (with-syntax ((lens* (lens-name field))
+                       (accessor (accessor-name field)))
+           #'(define (lens* object)
+               (lambda (op)
+                 (accessor object
+                  (op (accessor object)))))))
+       fields))
+
+
 (define (syntax-name field)
   (syntax-case field ()
     ((name kvs ...)
@@ -187,6 +224,8 @@
              ;; Field accessors
              (build-accessor name field) ...
 
+             #,@(build-lenses stx #'(field ...))
+
              ;; if printer in attribute
              #,@(cond ((kv-ref #'(attribute ...) printer:)
                        => (lambda (printer)
-- 
cgit v1.2.3