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 +++++++++++++++++++++++++++++++++++++++++++++
 tests/test/object.scm      |  80 ++++++++++++++++++++
 2 files changed, 257 insertions(+)
 create mode 100644 module/hnh/util/object.scm
 create mode 100644 tests/test/object.scm

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 ...))))
diff --git a/tests/test/object.scm b/tests/test/object.scm
new file mode 100644
index 00000000..701c45c0
--- /dev/null
+++ b/tests/test/object.scm
@@ -0,0 +1,80 @@
+(define-module (test object)
+  :use-module (srfi srfi-64)
+  :use-module (srfi srfi-64 test-error)
+  :use-module (srfi srfi-88)
+  :use-module (hnh util object)
+  :use-module ((hnh util) :select (->)))
+
+(define-type (f) x)
+
+(test-group "Created procedures"
+            (test-assert "Constructor"  (procedure? f))
+            (test-assert "Predicate"    (procedure? f?))
+            (test-assert "Field access" (procedure? x)))
+
+;; (f)
+;; (f x: 10)
+;; (f? (f))
+
+(test-equal "Accessors are getters"
+  10 (x (f x: 10)))
+(test-assert "Accessors update, returning a object of the original type"
+  (f? (x (f x: 10) 20)))
+(test-equal "A get after an update returns the new value"
+  20 (-> (f x: 10)
+         (x 20)
+         x))
+
+
+(define-type (g) x)
+
+(test-assert "Second type can be created"
+  (g x: 10))
+
+(test-assert "Second type isn't first type"
+  (not (f? (g x: 10))))
+
+(test-assert "First type isn't second type"
+  (not (g? (f x: 10))))
+
+;; Tests that the old x gets shadowed
+;; (test-equal 10 (x (f x: 10)))
+;; (test-equal 10 (x (g x: 10)))
+
+;; field-level arguments
+;; - init:
+(define-type (f2) (f2-x default: 0 type: integer?))
+(test-equal 0 (f2-x (f2)))
+
+;; - type:
+
+(test-error "Giving an invalid type to the constructor throws an error"
+            'wrong-type-arg (f2 f2-x: 'hello))
+(test-error "Giving an invalid type to a setter throws an error"
+            'wrong-type-arg (f2-x (f2) 'hello))
+(test-equal "The error includes the name of the field, the expected type, and the given value"
+  '(f2-x integer? hello)
+  (catch 'wrong-type-arg (lambda () (f2-x (f2) 'hello))
+    (lambda (err proc fmt args data) args)))
+
+(test-equal "Typed setter updates the value"
+            (f2 f2-x: 10) (f2-x (f2) 10))
+
+;; type-level arguments
+;; - constructor:
+(define-type (f3 constructor: (lambda (make check)
+                                (lambda* (#:key f3-x f3-y)
+                                  (check f3-x f3-y)
+                                  (make f3-x f3-y))))
+  (f3-x type: integer?)
+  (f3-y type: string?))
+
+(test-assert "Custom constructors create objcets"
+  (f3? (f3 f3-x: 10 f3-y: "Hello")))
+
+(test-error "Bad arguments to custom constructor"
+            'wrong-type-arg (f3 f3-x: 'hello f3-y: 'world))
+
+;; - printer:
+(define-type (f4 printer: (lambda (r p) (display "something" p))))
+(test-equal "something" (with-output-to-string (lambda () (write (f4)))))
-- 
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

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 ba70d8de990c8a07bc258f909bf9e415a4671f78 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Tue, 28 Jun 2022 09:32:38 +0200
Subject: Add tests for lenses.

---
 tests/test/lens.scm | 21 +++++++++++++++++++++
 1 file changed, 21 insertions(+)
 create mode 100644 tests/test/lens.scm

diff --git a/tests/test/lens.scm b/tests/test/lens.scm
new file mode 100644
index 00000000..0797e3aa
--- /dev/null
+++ b/tests/test/lens.scm
@@ -0,0 +1,21 @@
+(define-module (test lens)
+  :use-module (srfi srfi-64)
+  :use-module (srfi srfi-64 test-error)
+  :use-module (srfi srfi-88)
+  :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))
+
+
+;; (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))
+
+;; (set (list (iota 10)) first first 11)
-- 
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 +-
 tests/test/datetime.scm                   |  40 +--
 tests/test/recurrence-advanced.scm        |   1 +
 7 files changed, 231 insertions(+), 286 deletions(-)

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))]
diff --git a/tests/test/datetime.scm b/tests/test/datetime.scm
index 2a5ac141..f73a0ad2 100644
--- a/tests/test/datetime.scm
+++ b/tests/test/datetime.scm
@@ -70,45 +70,44 @@
       (test-error "Invalid second" 'wrong-type-arg (time second: #f))))
 
   (test-group "Datetime"
-    (let ((get-time% (@@ (datetime) get-time%)))
+    (let ()
       (test-group "Empty datetime"
         (let ((dt (datetime)))
-          ;; TODO figure out propper export of get-time%
-          (test-assert "Datetime date is date" (date? (get-date dt)))
-          (test-assert "Datetime date is zero" (date-zero? (get-date dt)))
-          (test-assert "Datetime time is time" (time? (get-time% dt)))
-          (test-assert "Datetime time is zero" (time-zero? (get-time% dt)))
-          (test-eqv "Defalut timezone is #f" #f (get-timezone dt))))
+          (test-assert "Datetime date is date" (date? (datetime-date dt)))
+          (test-assert "Datetime date is zero" (date-zero? (datetime-date dt)))
+          (test-assert "Datetime time is time" (time? (datetime-time dt)))
+          (test-assert "Datetime time is zero" (time-zero? (datetime-time dt)))
+          (test-eqv "Defalut timezone is #f" #f (tz dt))))
 
       (test-group "Datetime with keys"
         (let ((dt (datetime date: (date day: 10)
                             time: (time minute: 20))))
           (test-equal "Given date is stored"
-            10 (day (get-date dt)))
+            10 (day (datetime-date dt)))
           (test-equal "Given time is stored"
-            20 (minute (get-time% dt))))
+            20 (minute (datetime-time dt))))
         (test-error "Date must be a date" 'wrong-type-arg (datetime date: 1))
         (test-error "Date must be a date" 'wrong-type-arg (datetime date: (time)))
-        (test-assert "Date: #f gives still constructs a date" (date? (get-date (datetime date: #f))))
+        (test-assert "Date: #f gives still constructs a date" (date? (datetime-date (datetime date: #f))))
         (test-error "Time must be a time" 'wrong-type-arg (datetime time: 1))
         (test-error "Time must be a time" 'wrong-type-arg (datetime time: (date)))
-        (test-assert "Time: #f gives still constructs a time" (time? (get-time% (datetime time: #f))))
+        (test-assert "Time: #f gives still constructs a time" (time? (datetime-time (datetime time: #f))))
 
         (let ((dt (datetime hour: 20 day: 30)))
-          (test-equal "Time objects can be implicitly created" 20 (hour (get-time% dt)))
-          (test-equal "Date objects can be implicitly created" 30 (day (get-date dt))))
+          (test-equal "Time objects can be implicitly created" 20 (hour (datetime-time dt)))
+          (test-equal "Date objects can be implicitly created" 30 (day (datetime-date dt))))
         (let ((dt (datetime day: 30 time: (time hour: 20))))
           (test-equal "\"Upper\" and \"lower\" keys can be mixed"
-            20 (hour (get-time% dt)))
+            20 (hour (datetime-time dt)))
           (test-equal "\"Upper\" and \"lower\" keys can be mixed"
-            30 (day (get-date dt))))
+            30 (day (datetime-date dt))))
 
         (let ((dt (datetime hour: 30 time: (time hour: 20))))
           (test-equal "time: has priority over hour: (and the like)"
-            20 (hour (get-time% dt)))))
+            20 (hour (datetime-time dt)))))
       (let ((dt (datetime day: 30 date: (date day: 20))))
         (test-equal "date: has priority over day: (and the like)"
-          20 (day (get-date dt)))))))
+          20 (day (datetime-date dt)))))))
 
 ;; Before the general parser, since it's a dependency string->datetime.
 (test-group "Parse Month"
@@ -384,7 +383,7 @@
 (test-assert "Current datetime returns a datetime"
   (datetime? (current-datetime)))
 (test-equal "Current datetime returns with tz: UTC"
-  "UTC" (get-timezone (current-datetime)))
+  "UTC" (tz (current-datetime)))
 (test-assert "Current-date returns a date"
   (date? (current-date)))
 
@@ -706,6 +705,11 @@ date-range
       (test-assert "negative comparison"
         (not (datetime< (datetime day: 1) (datetime day: 2) (datetime day: 1)))))))
 
+;; TODO
+date<=
+time<=
+datetime<=
+
 ;; TODO
 date/-time< date/-time<? date/-time<= date/-time<=?
 date/-time> date/-time>? date/-time>= date/-time>=?
diff --git a/tests/test/recurrence-advanced.scm b/tests/test/recurrence-advanced.scm
index a291cc17..56f4cda6 100644
--- a/tests/test/recurrence-advanced.scm
+++ b/tests/test/recurrence-advanced.scm
@@ -27,6 +27,7 @@
   :use-module ((datetime)
                :select (parse-ics-datetime
                         datetime
+                        datetime-date
                         time
                         date
                         datetime->string))
-- 
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(-)

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(+)

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


From b1a83d7239a5cdf838fafaf9fe1fe91b7c9e63ee Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Fri, 8 Jul 2022 13:15:25 +0200
Subject: Change list-of and pair-of validator to separate macros.

The functionallity is still the same, but this demonstrates that the
system is easily extensible.
---
 module/hnh/util/object.scm | 27 +++++++++++++++++----------
 1 file changed, 17 insertions(+), 10 deletions(-)

diff --git a/module/hnh/util/object.scm b/module/hnh/util/object.scm
index 4dbb45a8..d6fa6273 100644
--- a/module/hnh/util/object.scm
+++ b/module/hnh/util/object.scm
@@ -3,7 +3,9 @@
   :use-module (srfi srfi-9 gnu)
   :use-module (ice-9 curried-definitions)
   :use-module (hnh util)
-  :export (define-type))
+  :export (define-type
+            build-validator-body
+            list-of pair-of))
 
 
 
@@ -35,21 +37,26 @@
 
 
 
+(define-syntax list-of
+  (syntax-rules ()
+    ((_ variable (rule ...))
+     (and (list? variable)
+          (every (lambda (x) (build-validator-body x (rule ...))) variable)))
+    ((_ variable rule)
+     (and (list? variable)
+          (every rule variable)))))
+
+(define-syntax-rule (pair-of variable a b)
+  (and (pair? variable)
+       (build-validator-body (car variable) a)
+       (build-validator-body (cdr variable) b)))
+
 ;; 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 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 (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


From 1f12ecb04c63026464e25d8ede496465a8235543 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Sat, 9 Jul 2022 20:24:04 +0200
Subject: Move type checking macros to own module.

---
 module/hnh/util/object.scm | 30 ++----------------------------
 module/hnh/util/type.scm   | 46 ++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 48 insertions(+), 28 deletions(-)
 create mode 100644 module/hnh/util/type.scm

diff --git a/module/hnh/util/object.scm b/module/hnh/util/object.scm
index d6fa6273..4477b462 100644
--- a/module/hnh/util/object.scm
+++ b/module/hnh/util/object.scm
@@ -1,11 +1,9 @@
 (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
-            build-validator-body
-            list-of pair-of))
+  :use-module (hnh util type)
+  :export (define-type))
 
 
 
@@ -37,30 +35,6 @@
 
 
 
-(define-syntax list-of
-  (syntax-rules ()
-    ((_ variable (rule ...))
-     (and (list? variable)
-          (every (lambda (x) (build-validator-body x (rule ...))) variable)))
-    ((_ variable rule)
-     (and (list? variable)
-          (every rule variable)))))
-
-(define-syntax-rule (pair-of variable a b)
-  (and (pair? variable)
-       (build-validator-body (car variable) a)
-       (build-validator-body (cdr variable) b)))
-
-;; 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 list-of)
-    ((_ 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 ()
diff --git a/module/hnh/util/type.scm b/module/hnh/util/type.scm
new file mode 100644
index 00000000..800834e5
--- /dev/null
+++ b/module/hnh/util/type.scm
@@ -0,0 +1,46 @@
+(define-module (hnh util type)
+  :use-module ((srfi srfi-1) :select (every))
+  :export (build-validator-body
+           list-of pair-of
+           typecheck
+           current-procedure-name))
+
+(define-syntax list-of
+  (syntax-rules ()
+    ((_ variable (rule ...))
+     (and (list? variable)
+          (every (lambda (x) (build-validator-body x (rule ...))) variable)))
+    ((_ variable rule)
+     (and (list? variable)
+          (every rule variable)))))
+
+(define-syntax-rule (pair-of variable a b)
+  (and (pair? variable)
+       (build-validator-body (car variable) a)
+       (build-validator-body (cdr variable) b)))
+
+;; 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 list-of)
+    ((_ 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))))
+
+(define-syntax-rule (current-procedure-name)
+  ;; 1 since make-stack is at top of stack
+  (frame-procedure-name (stack-ref (make-stack #t) 1)))
+
+(define-syntax typecheck
+  (syntax-rules ()
+    ((_ variable type-clause)
+     (let ((procedure-name (current-procedure-name)))
+       (typecheck variable type-clause procedure-name)))
+    ((_ variable type-clause procedure-name)
+     (unless (build-validator-body variable type-clause)
+       (scm-error 'wrong-type-arg procedure-name
+                  "Invalid value for ~s. Expected ~s, got ~s"
+                  (list (quote variable) (quote type-clause) variable)
+                  #f)))))
+
-- 
cgit v1.2.3


From 1ec118a27fa56f1167cab990814f88d847056da5 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Sat, 9 Jul 2022 21:39:12 +0200
Subject: Document type and object system.

---
 doc/ref/guile.texi             |  2 +
 doc/ref/guile/util-object.texi | 86 ++++++++++++++++++++++++++++++++++++++++++
 doc/ref/guile/util-type.texi   | 62 ++++++++++++++++++++++++++++++
 3 files changed, 150 insertions(+)
 create mode 100644 doc/ref/guile/util-object.texi
 create mode 100644 doc/ref/guile/util-type.texi

diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi
index a6c5ebe4..58c162e1 100644
--- a/doc/ref/guile.texi
+++ b/doc/ref/guile.texi
@@ -7,6 +7,8 @@
 @include guile/util.texi
 @include guile/util-path.texi
 @include guile/util-config.texi
+@include guile/util-type.texi
+@include guile/util-object.texi
 @include guile/base64.texi
 @include guile/web.texi
 @include guile/vcomponent.texi
diff --git a/doc/ref/guile/util-object.texi b/doc/ref/guile/util-object.texi
new file mode 100644
index 00000000..ceac2f2a
--- /dev/null
+++ b/doc/ref/guile/util-object.texi
@@ -0,0 +1,86 @@
+@node define-type
+@section Yet Another Object System
+
+@defmac define-type (name type-parameters ...) fields ...
+Introduce a new type.
+
+Each field is either a symbol, or a list where the first element is a
+symbol, and the remaining elements are alternating keywords and
+values, as per @ref{Field Parameters}. All fields are optional by
+default, but can be made non-optional through its type parameter.
+
+The example below creates a new type called @var{type}, with a custom
+printer which always displays the string ``TYPE''. It has two fields,
+@var{x}, which must be an integer, and @var{y}, which can have any
+type, but gets the value ``Hello'' in none is given.
+@example
+(define-type (type #:printer (lambda (r p) (display "TYPE" p)))
+  (x #:type integer?)
+  (y #:default "Hello"))
+@end example
+@end defmac
+
+@subsection Type Parameters
+
+@deffn {Type Parameter} constructor (λ (primitive-constructor type-validator))
+Use a custom constructor for the type. The given procedure is called
+with two values:
+@itemize
+@item the types primitive (and usually hidden) constructor,
+which takes as many arguments as there are fields, in the order given
+in define-type, and
+@item the type validator procedure, which also takes all arguments,
+but instead either returns an undefined value if everything is fine,
+or throws @code{'wrong-type-arg} otherwise.
+@end itemize
+The procedure should then return a new procedure, which will be bound
+as the constructor for the type. Note that default values are current
+disregarded with custom constructors.
+
+A custom constructor for the type above might look like
+@example
+(lambda (primitive-constructor type-check)
+  (lambda* (#:key x y)
+    (type-check x y)
+    (primitive-constructor x y)))
+@end example
+@end deffn
+
+@deffn {Type Parameter} printer (λ (record port))
+Use a custom printer for the type.
+@end deffn
+
+@subsection Field Parameters
+@anchor{Field Parameters}
+
+@deffn {Field Parameter} default value
+Value the field should get if not given.
+@end deffn
+
+@deffn {Field Parameter} type type-clause
+A type predicate that the field must obey. See @ref{type-clause} for details.
+@end deffn
+
+@subsection Introduced Bindings
+
+Define type introduces a number procedures. (@var{<name>} should be
+replaced with whatever was given as @var{name} to define-type.
+
+@defun @var{<name>} [kv-args ...]
+Type constructor. Takes key-value arguments. Where the keys are the
+names of the fields.
+@end defun
+
+@defun @var{<name>}? x
+Type predicate.
+@end defun
+
+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
diff --git a/doc/ref/guile/util-type.texi b/doc/ref/guile/util-type.texi
new file mode 100644
index 00000000..104b00b3
--- /dev/null
+++ b/doc/ref/guile/util-type.texi
@@ -0,0 +1,62 @@
+@node Type utilities
+@section Type utilities
+
+Provided by the module @code{(hnh util type)}
+
+@subsection Type Clauses
+@anchor{type-clause}
+@cindex type-clause
+
+Type clauses are an effective way of writing compound predicates
+without explicitly mentioning the variable at all steps.
+
+The simplest type predicate is a single symbol, which is directly
+called on the object:
+@example
+predicate? ⇒ (predicate? x)
+@end example
+
+Otherwise, if the predicate is a list then the variable is spliced
+into the argument list in the first position:
+@example
+(proc args ...) ⇒ (proc x args ...)
+@end example
+
+The two primitives @code{and} and @code{or} are also available, which
+both take an arbitrary number of predicates, and calls them in order,
+with Scheme's usual short-circuiting rules.
+@footnote{@code{and} and @code{or} doesn't have to be primitives, but
+we would otherwise have one hell of a namespace conflict}
+
+@defmac list-of variable type-clause
+Checks if @var{variable} is a list, and that every element satisfies type-clause.
+@end defmac
+
+@defmac pair-of variable car-type-clause cdr-type-clause
+Check if @var{variable} is a cons-pair, and that the car satisfies
+@var{car-type-clause}, and that the cdr satisfies @var{cdr-type-clause}.
+@end defmac
+
+@subsection Deffinitions
+
+@defmac build-validator-body variable type-clause
+``Entry point'' of type clauses. Inserts variable into the
+type-clause, returning something ready to be passed along the eval (or
+rather, spliced into another macro).
+
+Also used if new ``primitives'' are to be added, such as list-of.
+@end defmac
+
+@defmac typecheck variable type-clause [procedure-name=(current-procedure-name)]
+Checks @var{variable} against @var{type-clause}, and raises
+@code{'wrong-type-argument} if it fails. @var{procedure-name} is used
+as the calling procedure for @code{scm-error}.
+
+Useful at the start of procedures.
+@end defmac
+
+
+@defmac current-procedure-name
+Returns the current procedure name as a symbol, or @code{#f} if not found.
+@end defmac
+
-- 
cgit v1.2.3