4 files changed, 124 insertions, 87 deletions

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)