From 3205aa7566752d1b78ab452272c465ed0895b4e9 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Mon, 27 Jun 2022 14:59:44 +0200
Subject: Add new object system.

fixup object tests.
---
 module/hnh/util/object.scm | 177 +++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 177 insertions(+)
 create mode 100644 module/hnh/util/object.scm

(limited to 'module')

diff --git a/module/hnh/util/object.scm b/module/hnh/util/object.scm
new file mode 100644
index 00000000..1ecacf8e
--- /dev/null
+++ b/module/hnh/util/object.scm
@@ -0,0 +1,177 @@
+(define-module (hnh util object)
+  :use-module (srfi srfi-1)
+  :use-module (srfi srfi-9 gnu)
+  :use-module (ice-9 curried-definitions)
+  :use-module (hnh util)
+  :export (define-type))
+
+;; If given a syntax list extract the first lexeme, if given a "symbol", return that.
+(define (syntax-first stx)
+  (syntax-case stx ()
+    ((a rest ...) #'a)
+    (a #'a)))
+
+(define (construct-syntax stx base transform)
+  (->> base
+       syntax->datum
+       (format #f transform)
+       string->symbol
+       (datum->syntax stx)))
+
+;; stx should be a syntax object of a key-value list on the form
+;; (key: value key2: value2)
+;; and target-key the datum which the target key unwraps to.
+;; returns the corresponding values syntax
+;; or #f if none is found
+(define (kv-ref stx target-key)
+  (syntax-case stx ()
+    ((key value rest ...)
+     (if (eqv? target-key (syntax->datum #'key))
+         #'value
+         (kv-ref #'(rest ...) target-key)))
+    (_ #f)))
+
+
+
+;; DSL for specifying type predicates
+;; Basically a procedure body, but the variable to test is implicit.
+(define-syntax build-validator-body
+  (syntax-rules (and or)
+    ((_ variable (and clauses ...))  (and (build-validator-body variable clauses) ...))
+    ((_ variable (or clauses ...))   (or (build-validator-body variable clauses) ...))
+    ((_ variable (proc args ...))    (proc variable args ...))
+    ((_ variable proc)               (proc variable))))
+
+
+;; Given (x type: predicate?), expand to a single `unless' form (otherwise #f)
+(define-syntax (validator stx)
+  (syntax-case stx ()
+    ((_ (name kvs ...))
+     (cond ((kv-ref #'(kvs ...) type:)
+            => (lambda (type-stx)
+                 (with-syntax ((type type-stx))
+                   #'(unless (build-validator-body name type)
+                       (scm-error 'wrong-type-arg "validator"
+                                  "Invalid value for `~s'. Expected ~s, got ~s"
+                                  (list (quote name) (quote type) name) #f)))))
+           (else #f)))
+    ((_ name) #f)))
+
+
+
+
+;; Get syntax for getter-procedure's symbol
+(define-syntax (field-get stx)
+  (syntax-case stx ()
+    ;; ((_ (name kv ...)) #'(field-get name))
+    ((_ type-name name)
+     (->>
+      (format #f "~a-~a-get"
+              (syntax->datum #'type-name)
+              (syntax->datum #'name))
+      string->symbol
+      (datum->syntax stx)))))
+
+;; get syntax for setter-procedure's symbol
+(define-syntax (field-set stx)
+  (syntax-case stx ()
+    ;; ((_ (name kv ...)) #'(field-set name))
+    ((_ type-name name)
+     (->>
+      (format #f "~a-~a-set"
+              (syntax->datum #'type-name)
+              (syntax->datum #'name))
+      string->symbol
+      (datum->syntax stx)))))
+
+;; Construct a field line for define-immutable-record-type
+(define ((field-declaration type) stx)
+  (syntax-case stx ()
+    (name
+     (with-syntax ((name-get (->> (format #f "~a-~a-get"
+                                          (syntax->datum type)
+                                          (syntax->datum #'name))
+                                  string->symbol
+                                  (datum->syntax stx)))
+                   (name-set (->> (format #f "~a-~a-set"
+                                          (syntax->datum type)
+                                          (syntax->datum #'name))
+                                  string->symbol
+                                  (datum->syntax stx))))
+       #'(name name-get name-set)))))
+
+;; Accessors are procedures for getting and setting fields in records
+(define-syntax (build-accessor stx)
+  (syntax-case stx ()
+    ((_ type-name (name kvs ...))
+     #'(define name
+         (case-lambda ((datum)
+                       ((field-get type-name name) datum))
+                      ((datum new-value)
+                       ;; validator uses the first field (in the list) as both
+                       ;; the name of the field, and a reference to the value of
+                       ;; the field. This ensures those two are the same for validator,
+                       ;; while keeping name bound to the accessor in the outer scope.
+                       (let ((name new-value))
+                         (validator (name kvs ...)))
+                       ((field-set type-name name) datum new-value)))))
+    ((_ type-name name) #'(build-accessor type-name (name)))))
+
+
+;; Go from my concept of field deffinitions, to what lambda* wants as arguments
+(define (lambda*-stx field)
+  (syntax-case field ()
+    ((name kvs ...)
+     (cond ((kv-ref #'(kvs ...) default:)
+            => (lambda (dflt) #`(name #,dflt)))
+           (else #'name)))
+    (name #'name)))
+
+
+
+(define-syntax (define-type stx)
+  (syntax-case stx ()
+    ((_ (name attribute ...) field ...)
+     ;; These names SHOULD leak
+     (with-syntax ((<type>? (construct-syntax stx #'name "~a?")))
+       ;; These names are manually constructed, since generated identifiers are
+       ;; only dependant on the source from which they orginate, which leads to
+       ;; multiple instances of <type> being equal for similar types...
+       ;; See the manual 6.10.10 Hygiene and the Top-Level
+       (with-syntax ((<type>      (construct-syntax stx #'name "<~a>"))
+                     (make-<type> (construct-syntax stx #'name "make-~a%")))
+         #`(begin
+             (define-immutable-record-type <type>
+               (make-<type> #,@(map syntax-first #'(field ...)))
+               <type>?
+               #,@(map (field-declaration #'name)
+                       (map syntax-first #'(field ...))))
+
+             ;; User-facing constructor
+             (define name
+               #,(cond ((kv-ref #'(attribute ...) constructor:)
+                        => (lambda (constructor-builder)
+                             #`(#,constructor-builder
+                                ;; primitive constructor
+                                make-<type>
+                                ;; Type validator
+                                (lambda #,(map syntax-first #'(field ...))
+                                  (validator field) ...))))
+                       (else #`(lambda* (key: #,@(map lambda*-stx #'(field ...)))
+                                 ;; Type validators
+                                 (validator field) ...
+                                 (make-<type> #,@(map syntax-first #'(field ...)))))))
+
+             ;; Field accessors
+             (build-accessor name field) ...
+
+             ;; if printer in attribute
+             #,@(cond ((kv-ref #'(attribute ...) printer:)
+                       => (lambda (printer)
+                            (list #`(set-record-type-printer! <type> #,printer))))
+                      (else '()))))))
+
+    ;; else, type name without extra attributes
+    #;
+    ((_ name field ...)
+     #'(define-type (name) field ...))))
-- 
cgit v1.2.3


From 57c731e248355c12105814163ea3af4e32088477 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Mon, 27 Jun 2022 14:59:54 +0200
Subject: Add lenses.

---
 module/hnh/util/lens.scm | 99 ++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 99 insertions(+)
 create mode 100644 module/hnh/util/lens.scm

(limited to 'module')

diff --git a/module/hnh/util/lens.scm b/module/hnh/util/lens.scm
new file mode 100644
index 00000000..7a8fbd19
--- /dev/null
+++ b/module/hnh/util/lens.scm
@@ -0,0 +1,99 @@
+(define-module (hnh util lens)
+  :use-module (srfi srfi-1)
+  :export (modify
+           modify*
+           set
+           get
+
+           identity-lens
+           compose-lenses
+           lens-compose
+
+           ref car* cdr*))
+
+
+(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 ...))))
+
+
+
+
+(define (make-lens getter setter)
+  (case-lambda ((datum) (getter datum))
+               ((datum new-value) (setter datum new-value))))
+
+(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 identity-lens
+  (case-lambda ((a) a)
+               ((_ a) a)))
+
+(define (compose-lenses% f g)
+  (build-lens (get f g) (set f g)))
+
+(define (compose-lenses . fs)
+  (reduce-right compose-lenses% identity-lens fs))
+
+(define lens-compose compose-lenses)
+
+
+
+(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)))))
+
+
+
+(define (ref idx)
+  (build-lens (list-ref idx) (list-change idx)))
+
+
+(define car* (make-lens car (lambda (pair value) (cons value (cdr pair)))))
+(define cdr* (make-lens cdr (lambda (pair value) (cons (car pair) value))))
-- 
cgit v1.2.3


From b22827a7977d2e8b11d30f9692d9da47ab8da738 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Sat, 25 Jun 2022 16:18:52 +0200
Subject: Change date/time interface.

---
 module/calp/html/view/calendar.scm        |   2 +-
 module/datetime.scm                       | 444 +++++++++++++-----------------
 module/datetime/zic.scm                   |   6 +-
 module/vcomponent/datetime/output.scm     |   2 +-
 module/vcomponent/recurrence/generate.scm |  22 +-
 5 files changed, 208 insertions(+), 268 deletions(-)

(limited to 'module')

diff --git a/module/calp/html/view/calendar.scm b/module/calp/html/view/calendar.scm
index 9378737f..3d70fb1b 100644
--- a/module/calp/html/view/calendar.scm
+++ b/module/calp/html/view/calendar.scm
@@ -171,7 +171,7 @@ window.default_calendar='~a';"
                          ;; Button to view week
                          (_ "Week"))
 
-                   ,(btn href: (date->string (set (day start-date) 1) "/month/~1.html")
+                   ,(btn href: (date->string (day start-date 1) "/month/~1.html")
                          ;; button to view month
                          (_ "Month"))
 
diff --git a/module/datetime.scm b/module/datetime.scm
index 8bba6e89..d54ba403 100644
--- a/module/datetime.scm
+++ b/module/datetime.scm
@@ -3,8 +3,6 @@
   :replace (second)
 
   :use-module (srfi srfi-1)
-  :use-module (srfi srfi-9)
-  :use-module (srfi srfi-9 gnu)
   :use-module (srfi srfi-41)
   :use-module (srfi srfi-71)
   :use-module (srfi srfi-88)
@@ -15,12 +13,13 @@
                         ->
                         ->>
                         swap
-                        set
                         label
                         span-upto
-                        set->
                         ))
 
+  :use-module (hnh util object)
+  :use-module (hnh util lens)
+
   :use-module (ice-9 i18n)
   :use-module (ice-9 format)
   :use-module (ice-9 regex)
@@ -37,8 +36,11 @@
 
            datetime
            datetime?
-           get-date
-           get-timezone
+           ;; get-date
+           ;; get-timezone
+           datetime-date
+           datetime-time
+           tz
 
            date-zero?
            time-zero?
@@ -171,45 +173,40 @@
   pre: (ensure (lambda (x) (<= sun x sat))))
 
 
-;;; RECORD TYPES
-
-;;; DATE
-
-(define-immutable-record-type <date>
-  (make-date year month day)
-  date?
-  (year year) (month month) (day day))
-
-(define* (date key: (year 0) (month 0) (day 0))
-  (unless (and (integer? year) (integer? month) (integer? day))
-    (scm-error 'wrong-type-arg "date"
-               "Year, month, and day must all be integers. ~s, ~s, ~s"
-               (list year month day)
-               #f))
-  (make-date year month day))
 
-(set-record-type-printer!
- <date> (lambda (r p) (display (date->string r "#~1") p)))
-
-
-;;; TIME
-
-(define-immutable-record-type <time>
-  (make-time hour minute second)
-  time?
-  (hour hour) (minute minute) (second second))
-
-(define* (time key: (hour 0) (minute 0) (second 0))
-  (unless (and (integer? hour) (integer? minute) (integer? second))
-    (scm-error 'wrong-type-arg "time"
-               "Hour, minute, and second must all be integers. ~s, ~s, ~s"
-               (list hour minute second)
-               #f))
-  (make-time hour minute second))
+;;; RECORD TYPES
 
-(set-record-type-printer!
- <time>
- (lambda (r p) (display (time->string r "#~3") p)))
+(define-type (date printer: (lambda (r p) (display (date->string r "#~1") p)))
+  (year  default: 0 type: integer?)
+  (month default: 0 type: integer?)
+  (day   default: 0 type: integer?))
+
+(define-type (time printer: (lambda (r p) (display (time->string r "#~3") p)))
+  (hour   default: 0 type: integer?)
+  (minute default: 0 type: integer?)
+  (second default: 0 type: integer?))
+
+(define (datetime-constructor-constructor constructor validator)
+  (let ((date% date)
+        (time% time))
+   (lambda* (key: date time tz
+                  (year 0) (month 0) (day 0)
+                  (hour 0) (minute 0) (second 0))
+     (let ((date (or date (date% year: year month: month day: day)))
+           (time (or time (time% hour: hour minute: minute second: second))))
+       (validator date time tz)
+       (constructor date time tz)))))
+
+(define-type (datetime
+              constructor: datetime-constructor-constructor
+              printer: (lambda (r p)
+                         (if (and (tz r) (not (string=? "UTC" (tz r))))
+                             (write (datetime->sexp r) p)
+                             (display (datetime->string r "#~1T~3~Z") p))))
+
+  (datetime-date type: date?)
+  (datetime-time type: time?)
+  tz)
 
 
 (define (date-zero? date)
@@ -218,53 +215,14 @@
 (define (time-zero? time)
   (= 0 (hour time) (minute time) (second time)))
 
-;;; DATETIME
-
-(define-immutable-record-type <datetime>
-  (make-datetime date time tz)
-  datetime?
-  (date get-date)
-  (time get-time%)
-  (tz tz) ; #f for localtime, "UTC", "Europe/Stockholm", ...
-  )
-
-(define (get-timezone datetime)
-  (tz datetime))
-
-
-(define* (datetime
-          key: date time
-          (year 0) (month 0) (day 0)
-          (hour 0) (minute 0) (second 0)
-          tz)
-  (let ((date (or date (make-date year month day)))
-        (time (or time (make-time hour minute second))))
-    (unless (date? date)
-      (scm-error 'wrong-type-arg "datetime"
-                 "Date must be a date object, got ~s"
-                 (list date) (list date)))
-    (unless (time? time)
-      (scm-error 'wrong-type-arg "datetime"
-                 "Time must be a time object, got ~s"
-                 (list time) (list time)))
-   (make-datetime date time tz)))
-
-(set-record-type-printer!
- <datetime>
- (lambda (r p)
-   (if (and (tz r) (not (string=? "UTC" (tz r))))
-       (write (datetime->sexp r) p)
-       (display (datetime->string r "#~1T~3~Z") p))))
-
-
 
 
 ;; NOTE there isn't any stable way to craft the tm objects.
 ;; I could call mktime on some date, and replace the fields
 ;; with the set-tm:*, but that is worse that breaking the API.
 (define (datetime->tm datetime)
-  (let ((t (get-time% datetime))
-        (d (get-date  datetime)))
+  (let ((t (datetime-time datetime))
+        (d (datetime-date datetime)))
     (vector (second t)
             (minute t)
             (hour t)
@@ -296,8 +254,8 @@
 (define (unix-time->datetime n)
   ;; tm->datetime returns GMT here (as hinted by the
   ;; name @var{gmtime}). Blindly change it to UTC.
-  (set (tz (tm->datetime (gmtime n)))
-       "UTC"))
+  (-> (tm->datetime (gmtime n))
+      (tz "UTC")))
 
 
 ;; this returns UTC time, with a TZ component set to "UTC"
@@ -305,7 +263,7 @@
   (unix-time->datetime ((@ (guile) current-time))))
 
 (define (current-date)
-  (get-date (current-datetime)))
+  (datetime-date (current-datetime)))
 
 
 
@@ -324,10 +282,11 @@
                    [(string=? "local" (tz dt)) (mktime v)]
                    [else (mktime v (tz dt))])))))
       ;; strip tz-name, to conform with my local time.
-      (set (tz (tm->datetime tm)) #f))))
+      (-> (tm->datetime tm)
+          (tz #f)))))
 
 (define (as-date date/-time)
-  (cond [(datetime? date/-time) (get-date date/-time)]
+  (cond [date/-time datetime? => datetime-date]
         [(date? date/-time) date/-time]
         [(time? date/-time) (date)]
         [else (scm-error 'wrong-type-arg
@@ -337,7 +296,7 @@
                      #f)]))
 
 (define (as-time date/-time)
-  (cond [(datetime? date/-time) (get-time% date/-time)]
+  (cond [date/-time datetime? => datetime-time]
         [(date? date/-time) (time)]
         [(time? date/-time) date/-time]
         [else (scm-error 'wrong-type-arg "as-time"
@@ -379,15 +338,15 @@
       366 365))
 
 (define (start-of-month date)
-  (set (day date) 1))
+  (-> date (day 1)))
 
 (define (end-of-month date)
-  (set (day date) (days-in-month date)))
+  (-> date (day (days-in-month date))))
 
 (define (start-of-year date)
-  (set-> date
-         (day 1)
-         (month 1)))
+  (-> date
+      (day 1)
+      (month 1)))
 
 (define (date-stream date-increment start-day)
   (stream-iterate (lambda (d) (date+ d date-increment))
@@ -624,10 +583,10 @@
          (prev-month-len (days-in-month (date- date* (date month: 1))))
          (month-start (modulo (- (week-day date*) week-start) 7)))
     (values
-     (map (lambda (d) (set (day (date- date* (date month: 1))) d))
+     (map (lambda (d) (-> date* (date- (date month: 1)) (day d)))
           (iota month-start (1+ (- prev-month-len month-start))))
-     (map (lambda (d) (set (day date*) d)) (iota month-len 1))
-     (map (lambda (d) (set (day (date+ date* (date month: 1))) d))
+     (map (lambda (d) (day date* d)) (iota month-len 1))
+     (map (lambda (d) (-> date* (date+ (date month: 1)) (day d)))
           (iota (modulo (- (* 7 5) month-len month-start) 7) 1)))))
 
 
@@ -664,17 +623,17 @@
 
   (let ((date-diff
          (cond [start-date
-                (let ((end-date (date+ start-date (get-date dt))))
-                  (1- (days-in-interval start-date end-date))) ]
-               [(or (not (zero? (month (get-date dt))))
-                    (not (zero? (year (get-date dt)))))
+                (let ((end-date (date+ start-date (datetime-date dt))))
+                  (1- (days-in-interval start-date end-date)))]
+               [(or (not (zero? (month (datetime-date dt))))
+                    (not (zero? (year  (datetime-date dt)))))
                 (scm-error 'misc-error "datetime->decimal-hour"
                        "Multi-month intervals only supported when start-date is given (~a)"
                        (list dt)
                        #f)]
-               [else (day (get-date dt))])))
-    (+ (time->decimal-hour (get-time% dt))
-       (* date-diff 24))))
+               [else (-> dt datetime-date day)])))
+    (-> dt datetime-time time->decimal-hour
+        (+ (* date-diff 24)))))
 
 ;; Returns a list of all dates from start to end.
 ;; both inclusive
@@ -693,8 +652,8 @@
           (fmt "~1T~3")
           (locale %global-locale)
           key: allow-unknown?)
-  (define date (get-date datetime))
-  (define time (get-time% datetime))
+  (define date (datetime-date datetime))
+  (define time (datetime-time datetime))
   (with-output-to-string
     (lambda ()
       (fold (lambda (token state)
@@ -718,7 +677,7 @@
                    ((#\a) (display (week-day-name (week-day date) 3 locale: locale)))
                    ((#\B) (display (locale-month       (month date) locale)))
                    ((#\b) (display (locale-month-short (month date) locale)))
-                   ((#\Z) (when (equal? "UTC" (get-timezone datetime)) (display "Z")))
+                   ((#\Z) (when (equal? "UTC" (tz datetime)) (display "Z")))
                    (else (unless allow-unknown?
                            (scm-error 'misc-error "datetime->string"
                                   "Invalid format token ~a"
@@ -777,14 +736,6 @@ Returns -1 on failure"
     (define* (loop str fmt dt optional: (ampm ampm))
       (loop* str fmt dt ampm))
 
-    (define time (get-time% dt))
-    (define date (get-date dt))
-    (define zone (get-timezone dt))
-    (define (as-dt dt)
-      (cond [(date? dt) (datetime date: dt time: time tz: zone)]
-            [(time? dt) (datetime date: date time: dt tz: zone)]
-            [else dt]))
-
     (cond [(and (null? str) (null? fmt))
            (ampm dt)]
           [(null? str)
@@ -811,7 +762,7 @@ Returns -1 on failure"
               (if (eq? #\Z (car str))
                   (loop (cdr str)
                         (cddr fmt)
-                        (set (tz dt) "UTC"))
+                        (tz dt "UTC"))
                   (loop str
                         (cddr fmt)
                         dt))]
@@ -825,17 +776,13 @@ Returns -1 on failure"
                                 (case (string-ref (match:substring m 1) 0)
                                   ((#\a #\A)
                                    (lambda (dt)
-                                     (datetime date: (get-date dt)
-                                               time: (if (= 12 (hour (get-time% dt)))
-                                                         (set (hour (get-time% dt)) 0)
-                                                         (get-time% dt)))))
+                                     (modify* dt datetime-time hour
+                                              (lambda (x) (if (= x 12) 0 x)))))
                                   ((#\p #\P)
                                    (lambda (dt)
-                                     (datetime date: (get-date dt)
-                                               time: (if (= 12 (hour (get-time% dt)))
-                                                         (get-time% dt)
-                                                         (set (hour (get-time% dt))
-                                                              (+ 12 (hour (get-time% dt))))))))))
+                                     (modify* dt datetime-time hour
+                                              (lambda (x) (if (= x 12)
+                                                         x (+ x 12))))))))
                           ))
                     ;; fail here?
                     (else (loop str (cddr fmt) dt)))
@@ -853,8 +800,8 @@ Returns -1 on failure"
                             ((next-char rest ...) (span (lambda (c) (not (eqv? c next-char))) str)))))
                 (loop post
                       (cddr fmt)
-                      (as-dt (set (month date)
-                                  (parse-month (list->string head) locale)))))]
+                      (set dt datetime-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,
               ;; e.g. 7 may, but also compact, digits only, form without delimiters,
@@ -864,13 +811,14 @@ Returns -1 on failure"
                 (loop
                  post
                  (cddr fmt)
-                 (as-dt
-                  (case (cadr fmt)
-                    [(#\H) (set (hour time)   num)]
-                    [(#\M) (set (minute time) num)]
-                    [(#\S) (set (second time) num)]
-                    [(#\m) (set (month date)  num)]
-                    [(#\d) (set (day date)    num)]))))]
+                 (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)])))
+                   (set dt lens num))))]
 
              [(#\Y)
               (let* ((pre post (span-upto 4 char-numeric? str))
@@ -878,7 +826,7 @@ Returns -1 on failure"
                 (loop
                  post
                  (cddr fmt)
-                 (as-dt (set (year date) num))))]
+                 (set dt datetime-date year num)))]
 
              [else (err "Unimplemented or incorrect parse token ~S" str)])]
           [else
@@ -894,11 +842,11 @@ Returns -1 on failure"
 
 (define* (string->time str optional: (fmt "~H:~M:~S") (locale %global-locale)
                        key: return-trailing)
-  (get-time% (string->datetime str fmt locale return-trailing: return-trailing)))
+  (datetime-time (string->datetime str fmt locale return-trailing: return-trailing)))
 
 (define* (string->date str optional: (fmt "~Y-~m-~d") (locale %global-locale)
                        key: return-trailing)
-  (get-date (string->datetime str fmt locale return-trailing: return-trailing)))
+  (datetime-date (string->datetime str fmt locale return-trailing: return-trailing)))
 
 ;; Parse @var{string} as either a date, time, or date-time.
 ;; String MUST be on iso-8601 format.
@@ -924,7 +872,7 @@ Returns -1 on failure"
   (let ((dt (string->datetime str "~Y~m~dT~H~M~S~Z")))
     (if (tz dt)
         dt
-        (set (tz dt) zone))))
+        (tz dt zone))))
 
 (define (parse-iso-date str)
   (string->date str))
@@ -949,8 +897,8 @@ Returns -1 on failure"
          second: ,(second t)))
 
 (define* (datetime->sexp dt optional: verbose)
-  `(datetime date: ,(if verbose (date->sexp (get-date dt)) (get-date dt))
-             time: ,(if verbose (time->sexp (get-time% dt)) (get-time% dt))
+  `(datetime date: ,(if verbose (date->sexp (datetime-date dt)) (datetime-date dt))
+             time: ,(if verbose (time->sexp (datetime-time dt)) (datetime-time dt))
              tz: ,(tz dt)))
 
 
@@ -992,8 +940,8 @@ Returns -1 on failure"
 
 (define (datetime= . args)
   (reduce (lambda (a b)
-            (and (date= (get-date a) (get-date b))
-                 (time= (get-time% a) (get-time% b))
+            (and (date= (datetime-date a) (datetime-date b))
+                 (time= (datetime-time a) (datetime-time b))
                  a))
           #t args))
 
@@ -1053,16 +1001,16 @@ Returns -1 on failure"
 (define datetime<
   (fold-comparator
    (lambda (a b)
-     (if (date= (get-date a) (get-date b))
-         (time< (get-time% a) (get-time% b))
-         (date< (get-date a) (get-date b))))))
+     (if (date= (datetime-date a) (datetime-date b))
+         (time< (datetime-time a) (datetime-time b))
+         (date< (datetime-date a) (datetime-date b))))))
 
 (define datetime<=
   (fold-comparator
    (lambda (a b)
-     (if (date= (get-date a) (get-date b))
-         (time<= (get-time% a) (get-time% b))
-         (date<= (get-date a) (get-date b))))))
+     (if (date= (datetime-date a) (datetime-date b))
+         (time<= (datetime-time a) (datetime-time b))
+         (date<= (datetime-date a) (datetime-date b))))))
 
 (define date/-time<
   (fold-comparator
@@ -1126,19 +1074,20 @@ Returns -1 on failure"
     (let loop ((target base) (change change))
       (if (>= (days-in-month target) (+ (day change) (day target)))
           ;; No date overflow, just add the change
-          (values (set-> target (day = (+ (day change))))
-                  (set-> change (day 0)))
+          (values (-> target (day (+ (day target)
+                                     (day change))))
+                  (day change 0))
           ;; Date (and possibly year) overflow
           (loop (if (= 12 (month target))
-                    (set-> target
-                           (year = (+ 1))
-                           (month 1)
-                           (day 1))
-                    (set-> target
-                           (month = (+ 1))
-                           (day 1)))
-                (set-> change
-                       (day = (- (1+ (- (days-in-month target) (day target))))))))))
+                    (-> (modify target year 1+)
+                        (month 1)
+                        (day 1))
+                    (-> (modify target month 1+)
+                        (day 1)))
+                (modify change day -
+                        (- (day target))
+                        (days-in-month target)
+                        1)))))
 
   (define-values (month-fixed change**)
     (if (date-zero? change*)
@@ -1146,20 +1095,19 @@ 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 (set-> target
-                        (year = (+ 1))
-                        (month 1))
-                 (set (month change) = (- (- 13 (month target)))))
-
+           (loop (-> (modify target year 1+)
+                     (month 1))
+                 (modify change month
+                         + (month target) -13))
            ;; if we don't overflow our date
-           (values (set (month target) = (+ (month change)))
-                   (set (month change) 0))
+           (values (modify target month + (month change))
+                   (month change 0))
 
            ))))
 
   ;; change** should here should have both month and date = 0
 
-  (set (year month-fixed) = (+ (year change**))))
+  (year month-fixed (+ (year month-fixed) (year change**))))
 
 (define (date+% change base)
 
@@ -1188,33 +1136,30 @@ Returns -1 on failure"
   (define-values (days-fixed change*)
     (let loop ((target base) (change change))
       (if (>= (day change) (day target))
-          (let ((new-change (set (day change) = (- (day target)))))
+          (let ((new-change (modify change day - (day target))))
             (loop (if (= 1 (month target))
-                      (set-> target
-                             (year = (- 1))
-                             (month 12)
-                             (day 31)              ; days in december
-                             )
-                      (set-> target
-                             (month = (- 1))
-                             (day (days-in-month (set (month target) = (- 1))))))
+                      (-> (modify target year 1-)
+                          (month 12)
+                          (day 31)              ; days in december
+                          )
+                      (let ((nm (modify target month 1-)))
+                        (day nm (days-in-month nm))))
                   new-change))
-          (values (set (day target) = (- (day change)))
-                  (set (day change) 0)))))
+          (values (modify target day - (day change))
+                  (day change 0)))))
 
   (define-values (month-fixed change**)
     (let loop ((target days-fixed) (change change*))
       (if (>= (month change) (month target))
-          (loop (set-> target
-                       (year = (- 1))
-                       (month 12))
-                (set (month change) = (- (month target))))
-          (values (set (month target) = (- (month change)))
-                  (set (month change) 0)))))
+          (loop (-> (modify target year 1-)
+                    (month 12))
+                (modify change month - (month target)))
+          (values (modify target month - (month change))
+                  (month change 0)))))
 
   ;; change** should here should have both month and date = 0
 
-  (set (year month-fixed) = (- (year change**))))
+  (modify month-fixed year - (year change**)))
 
 (define (date-% change base)
 
@@ -1248,28 +1193,28 @@ Returns -1 on failure"
   ;; while (day base) > (days-in-month base)
   ;;     month++; days -= (days-in-month base)
   (define second-fixed
-    (let loop ((target (set (second base) = (+ (second change)))))
+    (let loop ((target (modify base second + (second change))))
       (if (>= (second target) 60)
-          (loop (set-> target
-                       (minute = (+ 1))
-                       (second = (- 60))))
+          (loop (-> target
+                    (modify minute 1+)
+                    (modify second - 60)))
           target)))
 
   ;; while (month base) > 12
   ;;     year++; month -= 12
   (define minute-fixed
-    (let loop ((target (set (minute second-fixed) = (+ (minute change)))))
+    (let loop ((target (modify second-fixed minute + (minute change))))
       (if (>= (minute target) 60)
-          (loop (set-> target
-                       (hour = (+ 1))
-                       (minute = (- 60))))
+          (loop (-> target
+                    (modify hour 1+)
+                    (modify minute - 60)))
           target)))
 
-  (define hour-almost-fixed (set (hour minute-fixed) = (+ (hour change))))
+  (define hour-almost-fixed (modify minute-fixed hour + (hour change)))
 
   (if (<= 24 (hour hour-almost-fixed))
       (let ((div remainder (floor/ (hour hour-almost-fixed) 24)))
-        (values (set (hour hour-almost-fixed) remainder) div))
+        (values (hour hour-almost-fixed remainder) div))
       (values hour-almost-fixed 0)))
 
 ;;; PLUS
@@ -1289,28 +1234,26 @@ Returns -1 on failure"
   (define-values (second-fixed change*)
     (let loop ((target base) (change change))
       (if (> (second change) (second target))
-          (loop (set-> target
-                       (minute = (- 1))
-                       (second 60))
-                (set (second change) = (- (second target))))
-          (values (set (second target) = (- (second change)))
-                  (set (second change) 0)))))
+          (loop (-> (modify target minute 1-)
+                    (second 60))
+                (modify change second - (second target)))
+          (values (modify target second - (second change))
+                  (second change 0)))))
 
   (define-values (minute-fixed change**)
     (let loop ((target second-fixed) (change change*))
       (if (> (minute change) (minute target))
-          (loop (set-> target
-                       (hour = (- 1))
-                       (minute 60))
-                (set (minute change) = (- (minute target))))
-          (values (set (minute target) = (- (minute change)))
-                  (set (minute change) 0)))))
+          (loop (-> (modify target hour 1-)
+                    (minute 60))
+                (modify change minute - (minute target)))
+          (values (modify target minute - (minute change))
+                  (minute change 0)))))
 
   (if (>= (hour minute-fixed) (hour change**))
-      (values (set (hour minute-fixed) = (- (hour change**))) 0)
+      (values (modify minute-fixed hour - (hour change**)) 0)
       (let ((diff (- (hour minute-fixed)
                      (hour change**))))
-        (values (set (hour minute-fixed) (modulo diff 24))
+        (values (hour minute-fixed (modulo diff 24))
                 (abs (floor (/ diff 24)))))))
 
 ;; Goes backwards from base, returning the two values:
@@ -1331,21 +1274,20 @@ Returns -1 on failure"
 
 
 (define (datetime+ base change)
-  (let ((time overflow (time+ (get-time% base) (get-time% change))))
-    (datetime date: (date+ (get-date base)
-                           (get-date change)
-                           (date day: overflow))
-              time: time
-              tz: (get-timezone base)
-              )))
+  (let ((time* overflow (time+ (datetime-time base) (datetime-time change))))
+    (-> base
+        (modify datetime-date date+
+                (datetime-date change)
+                (date day: overflow))
+        (datetime-time time*))))
 
 (define (datetime- base change)
-  (let ((time underflow (time- (get-time% base) (get-time% change))))
-    (datetime date: (date- (get-date base)
-                           (get-date change)
-                           (date day: underflow))
-              time: time
-              tz: (tz base))))
+  (let ((time* underflow (time- (datetime-time base) (datetime-time change))))
+    (-> base
+        (modify datetime-date date-
+                (datetime-date change)
+                (date day: underflow))
+        (datetime-time time*))))
 
 ;;; the *-difference procedures takes two actual datetimes.
 ;;; date- instead takes a date and a delta (but NOT an actual date).
@@ -1357,20 +1299,18 @@ Returns -1 on failure"
   (define-values (b* a*)
     (let loop ((b b) (a a))
       (if (> (day a) (day b))
-          (let ((new-a (set (day a) = (- (1+ (day b))))))
+          (let ((new-a (day a (- (day a) (day b) 1))))
             (loop (if (= 0 (month b))
-                      (set-> b
-                             (year = (- 1))
-                             (month 11)
-                             (day 30)   ; Last day in december
-                             )
-                      (set-> b
-                             (month = (- 1))
-                             (day (1- (days-in-month b))))) ; last in prev month
+                      (-> (modify b year 1-)
+                          (month 11)
+                          (day 30)   ; Last day in december
+                          )
+                      (-> (modify b month 1-)
+                          (day (1- (days-in-month b))))) ; last in prev month
                   new-a))
           ;; elif (> (day b) (day a))
-          (values (set (day b) = (- (day a)))
-                  (set (day a) 0)))))
+          (values (day b (- (day b) (day a)))
+                  (day a 0)))))
 
 
   ;; (day a*) should be 0 here.
@@ -1378,17 +1318,16 @@ Returns -1 on failure"
   (define-values (b** a**)
     (let loop ((b b*) (a a*))
       (if (> (month a) (month b))
-          (loop (set-> b
-                       (year = (- 1))
-                       (month 11))
-                (set (month a) = (- (1+ (month b)))))
+          (loop (-> (modify b year 1-)
+                    (month 11))
+                (modify a month - 1 (month b)))
           ;; elif (> (month b) (month a))
-          (values (set (month b) = (- (month a)))
-                  (set (month a) 0)))))
+          (values (modify b month - (month a))
+                  (month a 0)))))
 
   ;; a** should here should have both month and date = 0
 
-  (set (year b**) = (- (year a**))))
+  (year b** (- (year b**) (year a**))))
 
 
 
@@ -1407,20 +1346,21 @@ Returns -1 on failure"
            (list earlier-date later-date)
            #f))
 
-  (date-difference% (set-> later-date
-                           (month = (- 1))
-                           (day = (- 1)))
-                    (set-> earlier-date
-                           (month = (- 1))
-                           (day = (- 1)))))
+  (let ((proc (lambda (d) (-> d
+                         (modify month 1-)
+                         (modify day 1-)))))
+    (date-difference% (proc later-date)
+                      (proc earlier-date))))
 
 
 ;; NOTE, this is only properly defined when end is greater than start.
 (define (datetime-difference end start)
   ;; NOTE Makes both start and end datetimes in the current local time.
-  (let ((fixed-time overflow (time- (get-time% end)
-                                    (get-time% start))))
-    (datetime date: (date-difference (date- (get-date end)
+  (let ((fixed-time overflow (time- (datetime-time end)
+                                    (datetime-time start))))
+    (datetime date: (date-difference (date- (datetime-date end)
                                             (date day: overflow))
-                                     (get-date start))
-              time: fixed-time)))
+                                     (datetime-date start))
+              time: fixed-time
+              ;; TODO TZ
+              )))
diff --git a/module/datetime/zic.scm b/module/datetime/zic.scm
index 66c0ba06..1c9b34ee 100644
--- a/module/datetime/zic.scm
+++ b/module/datetime/zic.scm
@@ -342,17 +342,17 @@
     (datetime
      date:
      (match (rule-on rule)
-       ((? number? on) (set (day d) on))
+       ((? number? on) (day d on))
        (('last n)
         (iterate (lambda (d) (date- d (date day: 1)))
                  (lambda (d) (eqv? n (week-day d)))
-                 (set (day d) (days-in-month d))))
+                 (day d (days-in-month d))))
        (((? (lambda (x) (memv x '(< >))) <>) wday base-day)
         (iterate (lambda (d) ((if (eq? '< <>)
                              date- date+)
                          d (date day: 1)))
                  (lambda (d) (eqv? wday (week-day d)))
-                 (set (day d) base-day))))
+                 (day d base-day))))
      tz: (case (timespec-type (rule-at rule))
            ((#\w) #f)
            ((#\s) (warning (_ "what even is \"Standard time\"‽")) #f)
diff --git a/module/vcomponent/datetime/output.scm b/module/vcomponent/datetime/output.scm
index 614438da..fb3d0478 100644
--- a/module/vcomponent/datetime/output.scm
+++ b/module/vcomponent/datetime/output.scm
@@ -73,7 +73,7 @@
          (let ((s (prop ev 'DTSTART))
                (e (prop ev 'DTEND)))
            (if e
-               (let ((fmt-str (if (date= (get-date s) (get-date e))
+               (let ((fmt-str (if (date= (datetime-date s) (datetime-date e))
                                   (_ "~H:~M")
                                   ;; Note the non-breaking space
                                   (_ "~Y-~m-~d ~H:~M"))))
diff --git a/module/vcomponent/recurrence/generate.scm b/module/vcomponent/recurrence/generate.scm
index 07305647..cc725b09 100644
--- a/module/vcomponent/recurrence/generate.scm
+++ b/module/vcomponent/recurrence/generate.scm
@@ -119,7 +119,7 @@
   (branching-fold
    (lambda (rule dt)
      (let* ((key value (car+cdr rule))
-            (d (if (date? dt) dt (get-date dt)))
+            (d (if (date? dt) dt (datetime-date dt)))
             ;; NOTE It's proably an error to give BYHOUR, BYMINUTE, and BYSECOND
             ;; rules for a date object. This doesn't warn if those are given, but
             ;; instead silently discards them.
@@ -128,8 +128,8 @@
                      (if (date? dt)
                          (if (date? o) o d)
                          (if (date? o)
-                             (datetime date: o time: t tz: (get-timezone dt))
-                             (datetime date: d time: o tz: (get-timezone dt)))))))
+                             (datetime date: o time: t tz: (tz dt))
+                             (datetime date: d time: o tz: (tz dt)))))))
        (case key
          [(BYMONTH)
           (if (and (eq? 'YEARLY (freq rrule))
@@ -141,11 +141,11 @@
                (concatenate
                 (map (lambda (wday)
                        (all-wday-in-month
-                        wday (start-of-month (set (month d) value))))
+                        wday (start-of-month (month d value))))
                      (map cdr (byday rrule)))))
 
               ;; else
-              (to-dt (set (month d) value)))]
+              (to-dt (month d value)))]
 
          [(BYDAY)
           (let* ((offset value (car+cdr value)))
@@ -201,12 +201,12 @@
          [(BYYEARDAY) (to-dt (date+ (start-of-year d)
                                     (date day: (1- value))))]
          [(BYMONTHDAY)
-          (to-dt (set (day d)
+          (to-dt (day d
                       (if (positive? value)
                           value (+ 1 value (days-in-month d)))))]
-         [(BYHOUR) (to-dt (set (hour t) value))]
-         [(BYMINUTE) (to-dt (set (minute t) value))]
-         [(BYSECOND) (to-dt (set (second t) value))]
+         [(BYHOUR) (to-dt (hour t value))]
+         [(BYMINUTE) (to-dt (minute t value))]
+         [(BYSECOND) (to-dt (second t value))]
          [else (scm-error 'wrong-type-arg "update"
                           "Unrecognized by-extender ~s"
                           key #f)])))
@@ -254,7 +254,7 @@
    (extend-recurrence-set
     rrule
     (if (date? base-date)
-        (date+ base-date (get-date (make-date-increment rrule)))
+        (date+ base-date (datetime-date (make-date-increment rrule)))
         (datetime+ base-date (make-date-increment rrule))))))
 
 (define ((month-mod d) value)
@@ -273,7 +273,7 @@
          #t
          (let ((key values (car+cdr (car remaining)))
                (t (as-time dt))
-               (d (if (date? dt) dt (get-date dt))))
+               (d (if (date? dt) dt (datetime-date dt))))
            (and (case key
                   [(BYMONTH) (memv (month d) values)]
                   [(BYMONTHDAY) (memv (day d) (map (month-mod d) values))]
-- 
cgit v1.2.3


From 2d73d445be2ada75746b55dea831b5e0a3764410 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Sun, 3 Jul 2022 12:35:01 +0200
Subject: Extend object type system to allow list-of.

---
 module/hnh/util/object.scm | 10 +++++++++-
 1 file changed, 9 insertions(+), 1 deletion(-)

(limited to 'module')

diff --git a/module/hnh/util/object.scm b/module/hnh/util/object.scm
index 1ecacf8e..6a26336e 100644
--- a/module/hnh/util/object.scm
+++ b/module/hnh/util/object.scm
@@ -5,6 +5,8 @@
   :use-module (hnh util)
   :export (define-type))
 
+
+
 ;; If given a syntax list extract the first lexeme, if given a "symbol", return that.
 (define (syntax-first stx)
   (syntax-case stx ()
@@ -36,9 +38,15 @@
 ;; DSL for specifying type predicates
 ;; Basically a procedure body, but the variable to test is implicit.
 (define-syntax build-validator-body
-  (syntax-rules (and or)
+  (syntax-rules (and or list-of)
     ((_ variable (and clauses ...))  (and (build-validator-body variable clauses) ...))
     ((_ variable (or clauses ...))   (or (build-validator-body variable clauses) ...))
+    ((_ variable (list-of (proc args ...)))
+     (and (list? variable)
+          (every (lambda (x) (build-validator-body x (proc args ...)))
+                 variable)))
+    ((_ variable (list-of proc))     (and (list? variable)
+                                          (every proc variable)))
     ((_ variable (proc args ...))    (proc variable args ...))
     ((_ variable proc)               (proc variable))))
 
-- 
cgit v1.2.3


From d11b2e3a0ec03a7f4b7a77cc3cf05497320aa09f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Thu, 7 Jul 2022 21:25:49 +0200
Subject: Add pair-of to object system.

---
 module/hnh/util/object.scm | 3 +++
 1 file changed, 3 insertions(+)

(limited to 'module')

diff --git a/module/hnh/util/object.scm b/module/hnh/util/object.scm
index 6a26336e..4dbb45a8 100644
--- a/module/hnh/util/object.scm
+++ b/module/hnh/util/object.scm
@@ -47,6 +47,9 @@
                  variable)))
     ((_ variable (list-of proc))     (and (list? variable)
                                           (every proc variable)))
+    ((_ variable (pair-of a b))      (and (pair? variable)
+                                          (build-validator-body (car variable) a)
+                                          (build-validator-body (cdr variable) b)))
     ((_ variable (proc args ...))    (proc variable args ...))
     ((_ variable proc)               (proc variable))))
 
-- 
cgit v1.2.3