From ffd0a028aefd203b4a42ded1e5a592e1b4d92dd7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= 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/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 +- 9 files changed, 198 insertions(+), 155 deletions(-) (limited to 'module') 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)) - :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? -- cgit v1.2.3