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.
---
 doc/ref/general/lens.texi                     |  93 ++++++++----------
 doc/ref/object/object.texi                    |  28 ++++--
 module/calp/webdav/property.scm               |   8 +-
 module/datetime.scm                           | 127 ++++++++++++------------
 module/datetime/timespec.scm                  |   4 +-
 module/hnh/util/coverage.scm                  |   9 +-
 module/hnh/util/lens.scm                      | 136 +++++++++++---------------
 module/hnh/util/object.scm                    |  41 +++++++-
 module/hnh/util/table.scm                     |  25 ++++-
 module/text/calendar.scm                      |   1 -
 module/vcomponent/base.scm                    |   2 +-
 tests/unit/util/hnh-util-lens.scm             |  68 ++++++++-----
 tests/unit/vcomponent/vcomponent-datetime.scm |   2 +-
 tests/unit/webdav/webdav-propfind.scm         |   2 +-
 14 files changed, 303 insertions(+), 243 deletions(-)

diff --git a/doc/ref/general/lens.texi b/doc/ref/general/lens.texi
index 144478c3..bdf05a61 100644
--- a/doc/ref/general/lens.texi
+++ b/doc/ref/general/lens.texi
@@ -3,69 +3,58 @@
 
 Provided by the module @code{(hnh util lens)}
 
-A lens system for Scheme. All these procedures are pure. In general,
-procedures fetching values from objects return that value, while
-procedures ``setting'' or ``mutating'' objects returns a new instance
-of the object, with the field in question replaced.
-
-Lenses aren't a special type, but rather procedures which return a
-value when called with one argument, and produce a new container with
-an updated value when called with two arguments.
-
-For example, the lens to focus the first element of a pair is
-implemented as:
-
-@lisp
-(define car*
-  (case-lambda ((pair) (car pair))
-               ((pair value) (cons value (cdr pair)))))
-@end lisp
-
-@defun compose-lenses lenses ...
-@defunx lens-compose lenses ...
-Creates a new lens, which is the compound from all the given lenses.
-
-Lenses composes left to right, so earlier lenses in @var{lenses} are
-applied earlier.
-@end defun
+A lens system for Scheme.
 
-@defmac get object lenses ...
-Do a deep lookup. Lenses are composed as per @code{compose-lenses}.
-@end defmac
+@subsection Overview
 
-@defmac set object lenses ... value
-Do a deep update of a field, and return a new object with the focused
-element replaced. Lenses are composed as per @code{compose-lenses}.
-@end defmac
+@subsection Using Lenses
 
-@defun modify object lens f args ...
+@defun modify container lens f
 Returns a new object, with the value focused by @var{lens} replaced by
 the result of calling @var{f}, with the old value, and the extra
 arguments given.
 @end defun
 
-@defmac modify* object lens ... f
-Like @code{modify}, but auto compose lenses, and don't allow extra
-arguments to @var{f}.
-@end defmac
+@defun set container lens value
+Like modify, but sets a fixed value.
+@end defun
 
-@defmac build-lens getter setter
-Where any of getter or setter can either be a single symbol, or a list.
-@end defmac
+@defun get container lens
+Get the value focused by lens. Only a single value can me focused.
+@end defun
 
-@deftp {Scheme Lens} identity-lens
-A lens focusing the given object. Showing the value returns the root
-value, and setting the value just returns the new value.
-@end deftp
+@defun traversed container lens
+Similar to @code{get}, but returns a list of all focused elements.
 
-@deftp {Scheme Lens} ref idx
-Focuses the element at index @var{idx} in a list.
-@end deftp
+Note that this ``runs'' the lens for each elemement, (where ``modify''
+doesn't). So use with caution.
+@end defun
 
-@deftp {Scheme Lens} car*
-@deftpx {Scheme Lens} cdr*
-Focuses the first or second element of a pair.
-@end deftp
+@defun lens-compose lenses ...
+@defunx compose-lens lenses ...
+Creates a new lens, which is the compound from all the given lenses.
 
-@defun each object lens proc
+Lenses composes left to right, so earlier lenses in @var{lenses} are
+applied earlier.
 @end defun
+
+@subsection Built in Lenses
+
+@deffn {Lens} car*
+@deffnx {Lens} cdr*
+Focuses the first or second element of a pair.
+@end deffn
+
+@deffn {Lens} ref idx
+Focuses the element at index @var{idx} in a list.
+@end deffn
+
+@deffn {Lens} identity-lens
+A lens focusing the given object. Showing the value returns the root
+value, and setting the value just returns the new value.
+@end deffn
+
+@deffn {Lens} focus-matching predicate
+A lens focusing each element of a list where @var{predicate} returns
+true. This may be multiple elements.
+@end deffn
diff --git a/doc/ref/object/object.texi b/doc/ref/object/object.texi
index a21ae9ea..f56a8162 100644
--- a/doc/ref/object/object.texi
+++ b/doc/ref/object/object.texi
@@ -89,6 +89,26 @@ symbol, and @emph{not} a keyword object.
 @end example
 @end deffn
 
+@deffn {Field Parameter} #:accessor name
+Explicit name for the accessor of this field. Will otherwise use the
+fields name.
+
+Each accessor is a procedure which either
+@itemize
+@item retrives the field from the record (if one argument was given), or
+@item returns a new record with that field replaced (if two arguments
+where given).
+@end itemize
+
+@end deffn
+
+@deffn {Field Parameter} #:lens name
+Explicit name for the lens
+@c TODO link to lens documentation
+focusing this field. Will use the fields
+name, with a star (``*'') appended by if unset..
+@end deffn
+
 Each type introduces a number of bindings, which are@footnote{
 @var{<name>} here refers to the name of the type
 }:
@@ -104,12 +124,4 @@ Type predicate.
 
 And for each field @var{<field>}:
 
-@defun @var{<field>} object [value]
-Accessor for the given filed.
-Returns the current value if called with only an object, and returns a
-new object with @var{field} set to @var{value} if called with two values.
-
-The updating version checks the type if #:type was given on creation.
-@end defun
-
 @end defmac
diff --git a/module/calp/webdav/property.scm b/module/calp/webdav/property.scm
index a8dac349..4e235f81 100644
--- a/module/calp/webdav/property.scm
+++ b/module/calp/webdav/property.scm
@@ -9,10 +9,10 @@
   :use-module (hnh util object)
   :use-module (calp namespaces)
   :export (propstat?
-           propstat-status-code
-           propstat-property
-           propstat-error
-           propstat-response-description
+           propstat-status-code          propstat-status-code*
+           propstat-property             propstat-property*
+           propstat-error                propstat-error*
+           propstat-response-description propstat-response-description*
 
            propstat
 
diff --git a/module/datetime.scm b/module/datetime.scm
index 9bede1f1..666724a7 100644
--- a/module/datetime.scm
+++ b/module/datetime.scm
@@ -29,10 +29,12 @@
   :export (date
            date?
            year month day
+           year* month* day*
 
            time
            time?
            hour minute second
+           hour* minute* second*
 
            datetime
            datetime?
@@ -40,7 +42,8 @@
            ;; get-timezone
            datetime-date
            datetime-time
-           tz
+           date* time*
+           tz tz*
 
            date-zero?
            time-zero?
@@ -204,8 +207,8 @@
                              (write (datetime->sexp r) p) ; NOCOV
                              (display (datetime->string r "#~1T~3~Z") p))))
 
-  (datetime-date type: date?)
-  (datetime-time type: time?)
+  (datetime-date type: date? lens: date*)
+  (datetime-time type: time? lens: time*)
   tz)
 
 
@@ -780,13 +783,13 @@ Returns -1 on failure"
                                 (case (string-ref (match:substring m 1) 0)
                                   ((#\a #\A)
                                    (lambda (dt)
-                                     (modify* dt datetime-time hour
-                                              (lambda (x) (if (= x 12) 0 x)))))
+                                     (modify dt (lens-compose time* hour*)
+                                             (lambda (x) (if (= x 12) 0 x)))))
                                   ((#\p #\P)
                                    (lambda (dt)
-                                     (modify* dt datetime-time hour
-                                              (lambda (x) (if (= x 12)
-                                                         x (+ x 12))))))))
+                                     (modify dt (lens-compose time* hour*)
+                                             (lambda (x) (if (= x 12)
+                                                        x (+ x 12))))))))
                           ))
                     ;; fail here?
                     (else (loop str (cddr fmt) dt)))
@@ -804,7 +807,7 @@ Returns -1 on failure"
                             ((next-char rest ...) (span (lambda (c) (not (eqv? c next-char))) str)))))
                 (loop post
                       (cddr fmt)
-                      (set dt datetime-date month
+                      (set dt (lens-compose date* month*)
                            (parse-month (list->string head) locale))))]
              [(#\H #\M #\S #\m #\d)
               ;; This captures both the possibility of a date with a single digit,
@@ -817,11 +820,11 @@ Returns -1 on failure"
                  (cddr fmt)
                  (let ((lens
                         (case (cadr fmt)
-                          [(#\H) (lens-compose datetime-time hour)]
-                          [(#\M) (lens-compose datetime-time minute)]
-                          [(#\S) (lens-compose datetime-time second)]
-                          [(#\m) (lens-compose datetime-date month)]
-                          [(#\d) (lens-compose datetime-date day)])))
+                          [(#\H) (lens-compose time* hour*)]
+                          [(#\M) (lens-compose time* minute*)]
+                          [(#\S) (lens-compose time* second*)]
+                          [(#\m) (lens-compose date* month*)]
+                          [(#\d) (lens-compose date* day*)])))
                    (set dt lens num))))]
 
              [(#\Y)
@@ -830,7 +833,7 @@ Returns -1 on failure"
                 (loop
                  post
                  (cddr fmt)
-                 (set dt datetime-date year num)))]
+                 (set dt (lens-compose date* year*) num)))]
 
              [else (err "Unimplemented or incorrect parse token ~S" str)])]
           [else
@@ -1090,15 +1093,17 @@ Returns -1 on failure"
                   (day change 0))
           ;; Date (and possibly year) overflow
           (loop (if (= 12 (month target))
-                    (-> (modify target year 1+)
+                    (-> (modify target year* 1+)
                         (month 1)
                         (day 1))
-                    (-> (modify target month 1+)
+                    (-> (modify target month* 1+)
                         (day 1)))
-                (modify change day -
-                        (- (day target))
-                        (days-in-month target)
-                        1)))))
+                ;; How did this ever work‽
+                (modify change day*
+                        (lambda (d) (- d
+                                  (- (day target))
+                                  (days-in-month target)
+                                  1)))))))
 
   (define-values (month-fixed change**)
     (if (date-zero? change*)
@@ -1106,12 +1111,12 @@ Returns -1 on failure"
      (let loop ((target days-fixed) (change change*))
        (if (< 12 (+ (month change) (month target)))
            ;; if we overflow into the next year
-           (loop (-> (modify target year 1+)
+           (loop (-> (modify target year* 1+)
                      (month 1))
-                 (modify change month
-                         + (month target) -13))
+                 (modify change month*
+                         (lambda (d) (+ d (month target) -13))))
            ;; if we don't overflow our date
-           (values (modify target month + (month change))
+           (values (modify target month* (lambda (d) (+ d (month change))))
                    (month change 0))
 
            ))))
@@ -1147,30 +1152,30 @@ Returns -1 on failure"
   (define-values (days-fixed change*)
     (let loop ((target base) (change change))
       (if (>= (day change) (day target))
-          (let ((new-change (modify change day - (day target))))
+          (let ((new-change (modify change day* (lambda (d) (- d (day target))))))
             (loop (if (= 1 (month target))
-                      (-> (modify target year 1-)
+                      (-> (modify target year* 1-)
                           (month 12)
                           (day 31)              ; days in december
                           )
-                      (let ((nm (modify target month 1-)))
+                      (let ((nm (modify target month* 1-)))
                         (day nm (days-in-month nm))))
                   new-change))
-          (values (modify target day - (day change))
+          (values (modify target day* (lambda (d) (- d (day change))))
                   (day change 0)))))
 
   (define-values (month-fixed change**)
     (let loop ((target days-fixed) (change change*))
       (if (>= (month change) (month target))
-          (loop (-> (modify target year 1-)
+          (loop (-> (modify target year* 1-)
                     (month 12))
-                (modify change month - (month target)))
-          (values (modify target month - (month change))
+                (modify change month* (lambda (d) (- d (month target)))))
+          (values (modify target month* (lambda (d) (- d (month change))))
                   (month change 0)))))
 
   ;; change** should here should have both month and date = 0
 
-  (modify month-fixed year - (year change**)))
+  (modify month-fixed year* (lambda (d) (- d (year change**)))))
 
 (define (date-% change base)
 
@@ -1204,24 +1209,24 @@ Returns -1 on failure"
   ;; while (day base) > (days-in-month base)
   ;;     month++; days -= (days-in-month base)
   (define second-fixed
-    (let loop ((target (modify base second + (second change))))
+    (let loop ((target (modify base second* (lambda (d) (+ d (second change))))))
       (if (>= (second target) 60)
           (loop (-> target
-                    (modify minute 1+)
-                    (modify second - 60)))
+                    (modify minute* 1+)
+                    (modify second* (lambda (d) (- d 60)))))
           target)))
 
   ;; while (month base) > 12
   ;;     year++; month -= 12
   (define minute-fixed
-    (let loop ((target (modify second-fixed minute + (minute change))))
+    (let loop ((target (modify second-fixed minute* (lambda (d) (+ d (minute change))))))
       (if (>= (minute target) 60)
           (loop (-> target
-                    (modify hour 1+)
-                    (modify minute - 60)))
+                    (modify hour* 1+)
+                    (modify minute* (lambda (d) (- d 60)))))
           target)))
 
-  (define hour-almost-fixed (modify minute-fixed hour + (hour change)))
+  (define hour-almost-fixed (modify minute-fixed hour* (lambda (d) (+ d (hour change)))))
 
   (if (<= 24 (hour hour-almost-fixed))
       (let ((div remainder (floor/ (hour hour-almost-fixed) 24)))
@@ -1245,23 +1250,23 @@ Returns -1 on failure"
   (define-values (second-fixed change*)
     (let loop ((target base) (change change))
       (if (> (second change) (second target))
-          (loop (-> (modify target minute 1-)
+          (loop (-> (modify target minute* 1-)
                     (second 60))
-                (modify change second - (second target)))
-          (values (modify target second - (second change))
+                (modify change second* (lambda (d) (- d (second target)))))
+          (values (modify target second* (lambda (d) (- d (second change))))
                   (second change 0)))))
 
   (define-values (minute-fixed change**)
     (let loop ((target second-fixed) (change change*))
       (if (> (minute change) (minute target))
-          (loop (-> (modify target hour 1-)
+          (loop (-> (modify target hour* 1-)
                     (minute 60))
-                (modify change minute - (minute target)))
-          (values (modify target minute - (minute change))
+                (modify change minute* (lambda (d) (- d (minute target)))))
+          (values (modify target minute* (lambda (d) (- d (minute change))))
                   (minute change 0)))))
 
   (if (>= (hour minute-fixed) (hour change**))
-      (values (modify minute-fixed hour - (hour change**)) 0)
+      (values (modify minute-fixed hour* (lambda (d) (- d (hour change**)))) 0)
       (let ((diff (- (hour minute-fixed)
                      (hour change**))))
         (values (hour minute-fixed (modulo diff 24))
@@ -1287,17 +1292,19 @@ Returns -1 on failure"
 (define (datetime+ base change)
   (let ((time* overflow (time+ (datetime-time base) (datetime-time change))))
     (-> base
-        (modify datetime-date date+
-                (datetime-date change)
-                (date day: overflow))
+        (modify date*
+                (lambda (d) (date+ d
+                              (datetime-date change)
+                              (date day: overflow))))
         (datetime-time time*))))
 
 (define (datetime- base change)
   (let ((time* underflow (time- (datetime-time base) (datetime-time change))))
     (-> base
-        (modify datetime-date date-
-                (datetime-date change)
-                (date day: underflow))
+        (modify date*
+                (lambda (d) (date- d
+                              (datetime-date change)
+                              (date day: underflow))))
         (datetime-time time*))))
 
 ;;; the *-difference procedures takes two actual datetimes.
@@ -1312,11 +1319,11 @@ Returns -1 on failure"
       (if (> (day a) (day b))
           (let ((new-a (day a (- (day a) (day b) 1))))
             (loop (if (= 0 (month b))
-                      (-> (modify b year 1-)
+                      (-> (modify b year* 1-)
                           (month 11)
                           (day 30)   ; Last day in december
                           )
-                      (-> (modify b month 1-)
+                      (-> (modify b month* 1-)
                           (day (1- (days-in-month b))))) ; last in prev month
                   new-a))
           ;; elif (> (day b) (day a))
@@ -1329,11 +1336,11 @@ Returns -1 on failure"
   (define-values (b** a**)
     (let loop ((b b*) (a a*))
       (if (> (month a) (month b))
-          (loop (-> (modify b year 1-)
+          (loop (-> (modify b year* 1-)
                     (month 11))
-                (modify a month - 1 (month b)))
+                (modify a month* (lambda (d) (- d 1 (month b)))))
           ;; elif (> (month b) (month a))
-          (values (modify b month - (month a))
+          (values (modify b month* (lambda (d) (- d (month a))))
                   (month a 0)))))
 
   ;; a** should here should have both month and date = 0
@@ -1358,8 +1365,8 @@ Returns -1 on failure"
            #f))
 
   (let ((proc (lambda (d) (-> d
-                         (modify month 1-)
-                         (modify day 1-)))))
+                         (modify month* 1-)
+                         (modify day* 1-)))))
     (date-difference% (proc later-date)
                       (proc earlier-date))))
 
diff --git a/module/datetime/timespec.scm b/module/datetime/timespec.scm
index 7ea448a0..951ea729 100644
--- a/module/datetime/timespec.scm
+++ b/module/datetime/timespec.scm
@@ -58,8 +58,8 @@
              ;; + +
              [(eq? (timespec-sign done)
                    (timespec-sign spec))
-              (modify done timespec-time
-                      time+ (timespec-time spec))]
+              (modify done timespec-time*
+                      (lambda (t) (time+ t (timespec-time spec))))]
              ;; - +
              [(and (eq? '- (timespec-sign done))
                    (eq? '+ (timespec-sign spec)))
diff --git a/module/hnh/util/coverage.scm b/module/hnh/util/coverage.scm
index 15bdd250..8dc65bb8 100644
--- a/module/hnh/util/coverage.scm
+++ b/module/hnh/util/coverage.scm
@@ -67,14 +67,15 @@
    (fold (lambda (line state)
            (match (parse-coverage-line line)
              (('DA line hits)
-              (modify state (compose-lenses car* lines)
+              ;; TODO focus further?
+              (modify state (compose-lens car* lines*)
                       (lambda (lines) (cons (cons line hits) lines))))
              (('SF source)
-              (set state car* filename source))
+              (set state (lens-compose car* filename*) source))
              (('LH hit)
-              (set state car* hit-lines hit))
+              (set state (lens-compose car* hit-lines*) hit))
              (('LF lines)
-              (set state car* total-lines lines))
+              (set state (lens-compose car* total-lines*) lines))
              (('end-of-record)
               (cons (coverage-info) state))))
          (list (coverage-info))
diff --git a/module/hnh/util/lens.scm b/module/hnh/util/lens.scm
index 00f7fe1e..5932cce6 100644
--- a/module/hnh/util/lens.scm
+++ b/module/hnh/util/lens.scm
@@ -1,106 +1,82 @@
 (define-module (hnh util lens)
   :use-module (srfi srfi-1)
+  :use-module (ice-9 control)
+  :use-module (ice-9 curried-definitions)
   :export (modify
-           modify*
            set
            get
 
            identity-lens
-           compose-lenses
+           compose-lens
            lens-compose
 
-           ref car* cdr*
-
-           each))
-
-
-(define (modify object lens f . args)
-  (lens object (apply f (lens object) args)))
-
-(define-syntax modify*
-  (syntax-rules ()
-    ((_ object f) (f object))
-    ((_ object lens rest ...)
-     (modify object lens
-             (lambda (object*) (modify* object* rest ...))))))
-
-;; The simple case of getting and setting when you already have the lens is trivial
-;; (lens object)
-;; (lens object new-value)
-
-(define-syntax set
-  (syntax-rules ()
-    ((_ object lenses ... value)
-     (modify* object lenses ... (const value)))))
-
-(define-syntax get
-  (syntax-rules ()
-    ((_ object) object)
-    ((_ object f lenses ...)
-     (get (f object) lenses ...))))
-
-
+           focus-matching
+           traversed
 
+           ref car* cdr*
+           ))
 
-(define-syntax build-lens
-  (syntax-rules ()
-    ((_ (getter gargs ...)
-        (setter sargs ...))
-     ;; (make-lens (lambda (datum) (getter datum gargs ...))
-     ;;            (lambda (datum new-value) (setter datum sargs ... new-value)))
-     (case-lambda ((datum)
-                   (getter datum gargs ...))
-                  ((datum new-value)
-                   (setter datum sargs ... new-value))))
-    ((_ (getter args ...) setter)
-     (build-accesor (getter args ...) (setter)))
-    ((_ getter (setter args ...))
-     (build-lens (getter) (setter args ...)))
-    ((_ getter setter)
-     (build-lens (getter) (setter)))))
 
+(define ((car* lst) f)
+  (cons (f (car lst))                   ; ← focus
+        (cdr lst)))
 
-
+(define ((cdr* lst) f)
+  (cons (car lst)
+        (f (cdr lst))))
 
-(define identity-lens
-  (case-lambda ((a) a)
-               ((_ a) a)))
+(define (((ref idx) list) f)
+  (let loop ((idx idx) (rem list))
+    (if (zero? idx)
+        (cons (f (car rem))
+              (cdr rem))
+        (cons (car rem)
+              (loop (1- idx)
+                    (cdr rem))))))
 
-(define (compose-lenses% f g)
-  (build-lens (get f g) (set f g)))
+(define (((focus-matching predicate) list) f)
+  (map (lambda (x)
+         (if (predicate x)
+             (f x)
+             x))
+       list))
 
-(define (compose-lenses . fs)
-  (reduce-right compose-lenses% identity-lens fs))
 
-(define lens-compose compose-lenses)
+;;; Lens l i :: l i → (i → i) → l i
 
-
+;;; modify :: (l i, Lens l i, (i → i)) → l i
+(define (modify container lens f)
+  ((lens container) f))
 
-(define (list-change list index value)
-  (cond ((zero? index)
-         (cons value (cdr list)))
-        ((null? list)
-         (scm-error 'out-of-range "list-change" "" #f #f))
-        (else
-         (cons (car list)
-               (list-change (cdr list)
-                            (1- index)
-                            value)))))
+;;; set :: (l i, Lens l i, i) → l i
+(define (set container lens value)
+  (modify container lens (const value)))
 
+;;; get :: (l i, Lens l i) → i
+(define (get container lens)
+  (call/ec (lambda (return)
+             (modify container lens return))))
 
+(define (traversed container lens)
+  (define v '())
+  ((lens container) (lambda (x) (set! v (cons x v))))
+  v)
 
-(define (ref idx)
-  (build-lens (list-ref idx) (list-change idx)))
 
+(define lens-compose
+  (case-lambda
+    ((lens)
+     (lambda (object)
+       (lambda (operator)
+         (modify object lens operator))))
+    ((lens . lenses)
+     (lambda (object)
+       (lambda (operator)
+         (modify object lens
+                 (lambda (focus) (((apply lens-compose lenses) focus) operator))))))))
 
-(define car*
-  (case-lambda ((pair) (car pair))
-               ((pair value) (cons value (cdr pair)))))
+(define compose-lens lens-compose)
 
-(define cdr*
-  (case-lambda ((pair) (cdr pair))
-               ((pair value) (cons (car pair) value))))
 
-(define (each obj lens proc)
-  (modify obj lens
-          (lambda (lst) (map proc lst))))
+(define ((identity-lens object) op)
+  (op object))
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)
diff --git a/module/hnh/util/table.scm b/module/hnh/util/table.scm
index 23ce6cd4..b318cf77 100644
--- a/module/hnh/util/table.scm
+++ b/module/hnh/util/table.scm
@@ -49,12 +49,33 @@
   (or (tree-node? x)
       (tree-terminal? x)))
 
+;;; A lens
+;;; This function (tree-focus)
+;;; returns a function (f),
+;;; which takes a function (g).
+;;;
+;;; g will be given the focused value in the tree, and should return
+;;; the new value for that node
+;;;
+;;; f takes such a modifier function, and returns a new tree identical
+;;; to the old tree, but with the value of that node changed
+(define (tree-focus tree k)
+  (lambda (op)
+    (cond ((tree-terminal? tree) ;; new node
+           (tree-node key: k value: (op 'not-a-value)))
+          ((eq? k (key tree)) ;; this node
+           (value tree (op (value truee))))
+          (else
+           (if (symbol<? k (key tree))
+               (lens-compose left* (tree-focus (left tree) k))
+               (lens-compose right* (tree-focus (right tree k))))))))
+
 (define (tree-put tree k v)
   (cond ((tree-terminal? tree) (tree-node key: k value: v))
         ((eq? k (key tree)) (value tree v))
         (else
-         (modify tree (if (symbol<? k (key tree)) left right)
-                 tree-put k v))))
+         (modify tree (if (symbol<? k (key tree)) left* right*)
+                 (lambda (branch) (tree-put branch k v))))))
 
 (define* (tree-get tree k optional: default)
   (cond ((tree-terminal? tree) default)
diff --git a/module/text/calendar.scm b/module/text/calendar.scm
index 79341114..eece2b67 100644
--- a/module/text/calendar.scm
+++ b/module/text/calendar.scm
@@ -3,7 +3,6 @@
   :use-module (srfi srfi-71)
   :use-module (srfi srfi-88)
   :use-module ((hnh util) :select (when unless group ->))
-  :use-module ((hnh util lens) :select (modify))
   :use-module ((hnh util io) :select (displayln))
   :use-module (hnh util type)
   :use-module (ice-9 format)
diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm
index 95b14233..9b73a79e 100644
--- a/module/vcomponent/base.scm
+++ b/module/vcomponent/base.scm
@@ -161,7 +161,7 @@
   (map cdr (table->list (vcomponent-children c))))
 
 (define (add-child parent* child)
-  (modify parent* vcomponent-children
+  (modify parent* vcomponent-children*
           (lambda (table)
             (let ((child
                    ;; TODO is this the correct place to generate UIDs?
diff --git a/tests/unit/util/hnh-util-lens.scm b/tests/unit/util/hnh-util-lens.scm
index 0f4af6cb..6e8b5831 100644
--- a/tests/unit/util/hnh-util-lens.scm
+++ b/tests/unit/util/hnh-util-lens.scm
@@ -2,60 +2,76 @@
   :use-module (srfi srfi-64)
   :use-module (srfi srfi-64 test-error)
   :use-module (srfi srfi-88)
+  :use-module ((hnh util) :select (enumerate))
   :use-module (hnh util lens))
 
 
 (define first (ref 0))
 
-(test-equal '((1)) (first '(((1)))))
-(test-equal '((2)) (set '(((1))) (compose-lenses first first) 2))
-(test-equal '(((2))) (set '(((1))) (compose-lenses first first first) 2))
+(test-equal '((1)) (get '(((1))) first))
+
+(test-equal '((2)) (set '(((1))) (compose-lens first first) 2))
+(test-equal '(((2))) (set '(((1))) (compose-lens first first first) 2))
 
 
 ;; (list-change (iota 10) 5 'Hello)
 ;; => (0 1 2 3 4 Hello 6 7 8 9)
 
-(test-equal '(1 (10) 3) (set '(1 (2) 3) (compose-lenses (ref 1) (ref 0)) 10))
-(test-equal '(1 (10) 3) (set '(1 (2) 3) (ref 1) (ref 0) 10))
+(test-equal '(1 (10) 3) (set '(1 (2) 3)
+                             (compose-lens (ref 1) (ref 0))
+                             10))
+(test-equal '(1 (10) 3) (set '(1 (2) 3)
+                             (compose-lens (ref 1) (ref 0))
+                             10))
 
 ;; (set (list (iota 10)) first first 11)
 
-(define cadr* (compose-lenses cdr* car*))
+(define cadr* (compose-lens cdr* car*))
 
 (test-group "Primitive lenses get and set"
   (define lst '(1 2 3 4 5))
-  (test-equal 1 (car* lst))
-  (test-equal '(2 3 4 5) (cdr* lst))
+  (test-equal 1 (get lst car*))
+  (test-equal '(2 3 4 5) (get lst cdr*))
 
   (test-equal '(10 2 3 4 5)
-    (car* lst 10)))
+    (set lst car* 10)))
 
 (test-group "Primitive lens composition"
   (define lst '(1 2 3 4 5))
-  (test-equal 2 (cadr* lst))
-  (test-equal '(1 10 3 4 5) (cadr* lst 10)))
+  (test-equal 2 (get lst cadr*))
+  (test-equal '(1 10 3 4 5) (set lst cadr* 10)))
 
 (test-group "Modify"
   (define lst '(1 2 3 4 5))
-  (test-equal '(10 2 3 4 5) (modify lst car* * 10))
-  (test-equal '(1 20 3 4 5) (modify lst cadr* * 10))
+  (test-equal '(10 2 3 4 5) (modify lst car*  (lambda (x) (* x 10))))
+  (test-equal '(1 20 3 4 5) (modify lst cadr* (lambda (x) (* x 10))))
   )
 
 (test-group "Modify*"
   (define lst '(1 2 3 4 5))
-  (test-equal '(1 2 4 4 5) (modify* lst cdr* cdr* car* 1+)))
-
-;; modify
-;; modify*
-;; set
-;; get
-
-;; identity-lens
-;; compose-lenses
-;; lens-compose
-
-;; ref car* cdr*
+  (test-equal '(1 2 4 4 5)
+    (modify lst (lens-compose cdr* cdr* car*) 1+)))
+
+(test-equal
+    "!e!l!,!W!r!d"
+  (list->string
+   (map cadr
+        (set (enumerate (string->list "Hello, World"))
+             (compose-lens
+              (focus-matching (compose even? car))
+              cdr*)
+             '(#\!)))))
+
+
+(test-group "Identity lens"
+  (test-equal 'anything
+    (get 'anything identity-lens))
+  (test-equal 'else
+    (set 'anything identity-lens 'else))
+
+  (test-equal '(1 x 3)
+    (set '(1 2 3) (lens-compose cdr* identity-lens car*)
+         'x)))
 
-;; each
 
 '((hnh util lens))
diff --git a/tests/unit/vcomponent/vcomponent-datetime.scm b/tests/unit/vcomponent/vcomponent-datetime.scm
index de21281c..c997faba 100644
--- a/tests/unit/vcomponent/vcomponent-datetime.scm
+++ b/tests/unit/vcomponent/vcomponent-datetime.scm
@@ -70,7 +70,7 @@
          (ev (vevent dtstart: dt
                      dtend: (datetime+ dt (datetime hour: 5)))))
     (test-assert (event-contains? ev dt))
-    (test-assert (not (event-contains? ev (set dt datetime-date day 10))))))
+    (test-assert (not (event-contains? ev (set dt (lens-compose date* day*) 10))))))
 
 (test-group "event-zero-length?"
   (test-assert (not (event-zero-length? (vevent dtstart: (date)))))
diff --git a/tests/unit/webdav/webdav-propfind.scm b/tests/unit/webdav/webdav-propfind.scm
index 143fe1cd..8144605a 100644
--- a/tests/unit/webdav/webdav-propfind.scm
+++ b/tests/unit/webdav/webdav-propfind.scm
@@ -21,7 +21,7 @@
   (map
    (lambda (pr)
      (typecheck pr propstat?)
-     (modify pr propstat-property
+     (modify pr propstat-property*
              (lambda (it)
               (sort* it
                      string< (compose symbol->string xml-element-tagname car)))))
-- 
cgit v1.2.3