From 22f28015981295660ff98b43789f8c4c99134f36 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Mon, 16 Oct 2023 19:39:12 +0200
Subject: Move timespec and recur-rule to new object system.

---
 module/datetime/timespec.scm              |  27 ++++--
 module/datetime/zic.scm                   |  18 ++--
 module/hnh/util.scm                       |  22 -----
 module/vcomponent/formats/xcal/parse.scm  |   2 +-
 module/vcomponent/recurrence.scm          |   2 +-
 module/vcomponent/recurrence/internal.scm | 147 ++++++++++++++++--------------
 module/vcomponent/recurrence/parse.scm    | 130 +++++++++++---------------
 7 files changed, 160 insertions(+), 188 deletions(-)

(limited to 'module')

diff --git a/module/datetime/timespec.scm b/module/datetime/timespec.scm
index 53eba014..7ea448a0 100644
--- a/module/datetime/timespec.scm
+++ b/module/datetime/timespec.scm
@@ -4,12 +4,14 @@
 ;;; Code:
 
 (define-module (datetime timespec)
-  :use-module ((hnh util) :select (set unless))
+  :use-module ((hnh util) :select (unless))
   :use-module ((hnh util exceptions) :select (warning))
+  :use-module (hnh util object)
+  :use-module (hnh util lens)
   :use-module (datetime)
   :use-module (srfi srfi-1)
   :use-module (srfi srfi-71)
-  :use-module (srfi srfi-9 gnu)
+  :use-module (srfi srfi-88)
   :use-module (calp translation)
   :export (make-timespec
            timespec?
@@ -26,16 +28,22 @@
 ;; timespec as defined by the TZ-database
 ;; also used UTC-OFFSET defined by RFC5545. Then type should equal #\z
 ;; and be ignored.
-(define-immutable-record-type <timespec> ; EXPORTED
-  (make-timespec timespec-time sign type)
-  timespec?
-  (timespec-time timespec-time)         ; <time>
-  (sign timespec-sign)                  ; '+ | '-
+
+(define-type (timespec)
+  (timespec-time type: time?)
+  (timespec-sign type: (memv '(+ -)))
   ;; types:
   ;; w - wall clock time (local time)
   ;; s - standard time without daylight savings adjustments
   ;; u, g, z - Universal time
-  (type timespec-type))                 ; char
+  (timespec-type type: char?))
+
+;;; TODO remove make-timespec
+;;; It's a transient procedure while changing object system
+(define (make-timespec time sign type)
+  (timespec timespec-time: time
+            timespec-sign: sign
+            timespec-type: type))
 
 (define (timespec-zero)
   (make-timespec (time) '+ #\w))
@@ -50,7 +58,8 @@
              ;; + +
              [(eq? (timespec-sign done)
                    (timespec-sign spec))
-              (set (timespec-time done) = (time+ (timespec-time spec)))]
+              (modify done timespec-time
+                      time+ (timespec-time spec))]
              ;; - +
              [(and (eq? '- (timespec-sign done))
                    (eq? '+ (timespec-sign spec)))
diff --git a/module/datetime/zic.scm b/module/datetime/zic.scm
index acfb17a8..ad02cae0 100644
--- a/module/datetime/zic.scm
+++ b/module/datetime/zic.scm
@@ -12,7 +12,7 @@
 ;;; Code:
 (define-module (datetime zic)
   :use-module ((hnh util)
-               :select (awhen group set when sort* iterate group-by))
+               :select (awhen group when sort* iterate group-by))
   :use-module ((hnh util exceptions) :select (warning))
   :use-module (datetime)
   :use-module (datetime timespec)
@@ -23,7 +23,7 @@
   :use-module (srfi srfi-9 gnu)
   :use-module (srfi srfi-71)
   :use-module ((vcomponent recurrence internal)
-               :select (byday make-recur-rule bymonthday))
+               :select (byday recur-rule bymonthday))
   :use-module (calp translation)
   :export (read-zoneinfo
 
@@ -369,7 +369,7 @@
 (define (rule->rrule rule)
   (if (eq? 'only (rule-to rule))
       #f
-      (let ((base (make-recur-rule
+      (let ((base (recur-rule
                    freq: 'YEARLY
                    interval: 1
                    bymonth: (list (rule-in rule))
@@ -388,8 +388,8 @@
 
 
         (match (rule-on rule)
-          ((? number? d) (set (bymonthday base) (list d)))
-          (('last d)     (set (byday base) (list (cons -1 d))))
+          ((? number? d) (bymonthday base (list d)))
+          (('last d)     (byday base (list (cons -1 d))))
           (('< wday base-day) (scm-error 'misc-error "rule->rrule" (G_ "Counting backward for RRULES unsupported") #f #f))
           (('> wday base-day)
            ;; Sun<=25
@@ -398,10 +398,10 @@
            ;; something like Sun>=5 is hard to fix, since we can only
            ;; say which sunday in the month we want (first sunday,
            ;; second sunday, ...).
-           (set (byday base)
-                (list
-                 (cons (ceiling-quotient base-day 7)
-                       wday))))))))
+           (byday base
+                  (list
+                   (cons (ceiling-quotient base-day 7)
+                         wday))))))))
 
 ;; special case of format which works with %s and %z
 (define (zone-format fmt-string arg)
diff --git a/module/hnh/util.scm b/module/hnh/util.scm
index d888bea6..2ae5d2c4 100644
--- a/module/hnh/util.scm
+++ b/module/hnh/util.scm
@@ -3,7 +3,6 @@
   :use-module (srfi srfi-71)
   :use-module (srfi srfi-88)           ; postfix keywords
   :use-module ((sxml fold) :select (fold-values))
-  :use-module ((srfi srfi-9 gnu) :select (set-fields))
   :use-module ((ice-9 copy-tree) :select (copy-tree))
   :use-module ((ice-9 control) :select (call/ec))
   :export (aif
@@ -45,7 +44,6 @@
            insert-ordered
 
            -> ->>
-           set set->
            and=>>
 
            downcase-symbol
@@ -487,26 +485,6 @@
     ((->> obj func rest ...)
      (->> (func obj) rest ...))))
 
-;; Non-destructive set, syntax extension from set-fields from (srfi
-;; srfi-9 gnu).
-;;; TODO remove this, it's replaced by the true lens version
-(define-syntax set
-  (syntax-rules (=)
-    [(set (acc obj) value)
-     (set-fields
-      obj ((acc) value))]
-    [(set (acc obj) = (op rest ...))
-     (set-fields
-      obj ((acc) (op (acc obj) rest ...)))]))
-
-(define-syntax set->
-  (syntax-rules (=)
-    [(_ obj) obj]
-    [(_ obj (func = (op args ...)) rest ...)
-     (set-> (set (func obj) (op (func obj) args ...)) rest ...)]
-    [(_ obj (func args ...) rest ...)
-     (set-> (set (func obj) args ...) rest ...)]))
-
 (define-syntax and=>>
   (syntax-rules ()
     [(_ value) value]
diff --git a/module/vcomponent/formats/xcal/parse.scm b/module/vcomponent/formats/xcal/parse.scm
index 5ae1b928..d108b11c 100644
--- a/module/vcomponent/formats/xcal/parse.scm
+++ b/module/vcomponent/formats/xcal/parse.scm
@@ -96,7 +96,7 @@
 
        ;; freq until count interval wkst
 
-       (apply (@ (vcomponent recurrence internal) make-recur-rule)
+       (apply (@ (vcomponent recurrence internal) recur-rule)
               (concatenate
                (filter identity
                        (for key in '(bysecond byminute byhour byday bymonthday
diff --git a/module/vcomponent/recurrence.scm b/module/vcomponent/recurrence.scm
index ffda0e7f..f7e82a1e 100644
--- a/module/vcomponent/recurrence.scm
+++ b/module/vcomponent/recurrence.scm
@@ -4,4 +4,4 @@
   :use-module (vcomponent recurrence internal)
   :re-export (generate-recurrence-set
               parse-recurrence-rule
-              repeating? make-recur-rule))
+              repeating? recur-rule))
diff --git a/module/vcomponent/recurrence/internal.scm b/module/vcomponent/recurrence/internal.scm
index 9bf425ac..4b4cd336 100644
--- a/module/vcomponent/recurrence/internal.scm
+++ b/module/vcomponent/recurrence/internal.scm
@@ -4,20 +4,23 @@
   :use-module (srfi srfi-88)           ; better keywords
   :use-module ((vcomponent base) :select (prop))
   :use-module (ice-9 i18n)
-  :use-module (srfi srfi-9)
-  :use-module (srfi srfi-9 gnu)
   :use-module (ice-9 format)
+  :use-module (ice-9 pretty-print)
   :use-module (hnh util)
+  :use-module (hnh util object)
+  :use-module ((hnh util type) :select (list-of pair-of false?))
   :use-module (datetime)
 
   :replace (count)
   :export (repeating?
 
-           make-recur-rule
+           recur-rule
            freq until interval bysecond byminute byhour
            byday bymonthday byyearday byweekno bymonth bysetpos
            wkst
 
+           freq-placeholder
+
            recur-rule->rrule-string
            recur-rule->rrule-sxml
 
@@ -28,8 +31,11 @@
 (define weekdays
   (weekday-list sun))
 
+(define freq-placeholder (gensym))
+
 (define intervals
-  '(SECONDLY MINUTELY HOURLY DAILY WEEKLY MONTHLY YEARLY))
+  `(SECONDLY MINUTELY HOURLY DAILY WEEKLY MONTHLY YEARLY
+             ,freq-placeholder))
 
 
 ;; EXDATE is also a property linked to recurense rules
@@ -40,71 +46,74 @@
       (prop ev 'RDATE)
       (prop ev '-X-HNH-ALTERNATIVES)))
 
-;; weekday := [0, 7)
-
-;; Immutable, since I easily want to be able to generate the recurence set for
-;; the same event multiple times.
-(define-immutable-record-type <recur-rule>
-  (make-recur-rule% freq until count interval bysecond byminute byhour
-                    byday bymonthday byyearday byweekno bymonth bysetpos
-                    wkst)
-  recur-rule?
-  (freq freq) ; 'SECONDLY | 'MINUTELY | 'HOURLY | 'DAILY | 'WEEKLY | 'MONTHLY | 'YEARLY
-  (until until)                         ; <date> | <datetime>
-  (count count)                         ; 𝐙₊
-  (interval interval)                   ; 𝐙₊
-  (bysecond bysecond)                   ; (list [0, 60])
-  (byminute byminute)                   ; (list [0, 59])
-  (byhour byhour)                       ; (list [0, 23])
-  (byday byday)                         ; (list (cons [#f | 𝐙] weekday)
-  (bymonthday bymonthday)               ; (list [-31, 31] \ { 0 })
-  (byyearday byyearday)                 ; (list [-366, 366] \ { 0 })
-  (byweekno byweekno)                   ; (list [-53, 53] \ { 0 })
-  (bymonth bymonth)                     ; (list [-12, 12] \ { 0 })
-  (bysetpos bysetpos)                   ; (list [-366, 366] \ { 0 })
-  (wkst wkst)                           ; weekday
-  )
-
-
-
-;; Interval and wkst have default values, since those are assumed
-;; anyways, and having them set frees us from having to check them at
-;; the use site.
-(define* (make-recur-rule
-          key:
-          freq until count (interval 1) bysecond byminute byhour
-          byday bymonthday byyearday byweekno bymonth bysetpos
-          (wkst monday))
-  ;; TODO possibly validate fields here
-  ;; to prevent creation of invalid rules.
-  ;; This was made apparent when wkst was (incorrectly) set to MO,
-  ;; which later crashed generate-recurrence-set.
-
-  ;; Allow `(cons #f day)' to be written as just `day'.
-  (let ((byday* (if byday
-                    (map (lambda (day)
-                           (if (number? day)
-                               (cons #f day)
-                               day))
-                         byday)
-                    #f)))
-    (make-recur-rule% freq until count interval bysecond byminute byhour
-                      byday* bymonthday byyearday byweekno bymonth bysetpos
-                      wkst)))
-
-;; only print fields with actual values.
-(set-record-type-printer!
- <recur-rule>
- (lambda (r port)
-   (define (get f)
-     ((record-accessor <recur-rule> f) r))
-   (with-output-to-string
-     (lambda ()
-       (display "#<<recur-rule>" port)
-       (for field in (record-type-fields <recur-rule>)
-            (awhen (get field)
-                   (format port " ~a=~a" field it)))
-       (display ">" port)))))
+(define-syntax-rule (in-range? x start end)
+  (<= start x end))
+
+(define (recur-rule-constructor-factory primitive-constructor type-checker)
+  ;; Interval and wkst have default values, since those are assumed
+  ;; anyways, and having them set frees us from having to check them at
+  ;; the use site.
+  (lambda* (key: freq until count (interval 1) bysecond byminute
+                 byhour byday bymonthday byyearday byweekno bymonth
+                 bysetpos (wkst monday))
+    ;; Allow `(cons #f day)' to be written as just `day'.
+    (let ((byday* (if byday
+                      (map (lambda (day)
+                             (if (number? day)
+                                 (cons #f day)
+                                 day))
+                           byday)
+                      #f)))
+      ;; TODO possibly check that until and count are mutually exclusive
+      (type-checker
+       freq until count interval bysecond byminute byhour
+       byday* bymonthday byyearday byweekno bymonth bysetpos
+       wkst)
+      (primitive-constructor
+       freq until count interval bysecond byminute byhour
+       byday* bymonthday byyearday byweekno bymonth bysetpos
+       wkst))))
+
+(define (serialize-recur-rule record)
+  `(recur-rule
+    ,@(when (freq record) `(freq: ,(freq record)))
+    ,@(when (until record) `(until: ,(until record)))
+    ,@(when (count record) `(count: ,(count record)))
+    ,@(when (interval record) `(interval: ,(interval record)))
+    ,@(when (bysecond record) `(bysecond: ,(bysecond record)))
+    ,@(when (byminute record) `(byminute: ,(byminute record)))
+    ,@(when (byhour record) `(byhour: ,(byhour record)))
+    ,@(when (byday record) `(byday: ,(byday record)))
+    ,@(when (bymonthday record) `(bymonthday: ,(bymonthday record)))
+    ,@(when (byyearday record) `(byyearday: ,(byyearday record)))
+    ,@(when (byweekno record) `(byweekno: ,(byweekno record)))
+    ,@(when (bymonth record) `(bymonth: ,(bymonth record)))
+    ,@(when (bysetpos record) `(bysetpos: ,(bysetpos record)))
+    ,@(when (wkst record) `(wkst: ,(wkst record)))))
+
+;;; Both interval and wkst are optional by the standard.
+;;; We however default those to 1 and monday in the constructor
+;;; saving us from checking at the use site.
+(define-type (recur-rule
+              constructor: recur-rule-constructor-factory
+              printer: (lambda (record port)
+                         (pretty-print (serialize-recur-rule record)
+                                       port display?: #f)))
+  (freq       type: (memv intervals))
+  (until      type: (or false? date? datetime?))
+  (count      type: (or false? (and integer? positive?)))
+  (interval   type: (and integer? positive?))
+  (bysecond   type: (or false? (list-of (in-range? 0 60))))
+  (byminute   type: (or false? (list-of (in-range? 0 59))))
+  (byhour     type: (or false? (list-of (in-range? 0 23))))
+  (byday      type: (or false? (list-of (pair-of (or false? integer?)
+                                                 (memv weekdays)))))
+  (bymonthday type: (or false? (list-of (and (not zero?) (in-range? -31 31)))))
+  (byyearday  type: (or false? (list-of (and (not zero?) (in-range? -366 366)))))
+  (byweekno   type: (or false? (list-of (and (not zero?) (in-range? -53 53)))))
+  (bymonth    type: (or false? (list-of (and (not zero?) (in-range? -12 12)))))
+  (bysetpos   type: (or false? (list-of (and (not zero?) (in-range? -366 366)))))
+  (wkst       type: (memv weekdays)))
 
 
 (define (byday->string pair)
diff --git a/module/vcomponent/recurrence/parse.scm b/module/vcomponent/recurrence/parse.scm
index 12b6a622..ebe8b022 100644
--- a/module/vcomponent/recurrence/parse.scm
+++ b/module/vcomponent/recurrence/parse.scm
@@ -51,31 +51,6 @@
     (cons (string->number (list->string numbers))
           (rfc->datetime-weekday (apply symbol letters)))))
 
-(define-macro (quick-case key . cases)
-  (let ((else-clause (or (assoc-ref cases 'else)
-                         '(scm-error 'misc-error "quick-case"
-                                     "Guard failed"
-                                     #f #f))))
-    `(case ,key
-       ,@(map (match-lambda
-                ((key guard '=> body ...)
-                 `((,key) (if (not ,guard)
-                              (begin (warning
-                                      "RRULE guard failed for key ~a~%    guard: ~a : ~s"
-                                      (quote ,key)
-                                      (quote ,guard)
-                                      (map (lambda (o) (if (procedure? o)
-                                                      (procedure-name o)
-                                                      o))
-                                           (list ,@guard)))
-                                     ,@else-clause)
-                              (begin ,@body))))
-                ((key body ...)
-                 `((,key) (begin ,@body)))
-                (('else body ...)
-                 `(else ,@body)))
-              cases))))
-
 (define* (string->number/throw string optional: (radix 10))
   (or (string->number string radix)
       (scm-error 'wrong-type-arg
@@ -87,55 +62,56 @@
 ;; the same type as the DTSTART of the event (date or datetime). I have seen events
 ;; in the wild which didn't follow this. I consider that an user error.
 (define* (parse-recurrence-rule str optional: (datetime-parser parse-ics-datetime))
-  (fold
-   (lambda (kv o)
-     (let ((key (car kv))
-           (val (cadr kv)))
-       (let-lazy
-        ((symb (string->symbol val))
-         ;; NOTE until MUST have the same value type as DTSTART
-         ;; on the object. Idealy we would save that type and
-         ;; check it here. That however is impractical since we
-         ;; might encounter the RRULE field before the DTSTART
-         ;; field.
-         (date (if (= 8 (string-length val))
-                 (parse-ics-date val)
-                 (parse-ics-datetime val)))
-         (day (rfc->datetime-weekday (string->symbol val)))
-         (days (map parse-day-spec (string-split val #\,)))
-         (num  (string->number/throw val))
-         (nums (map string->number/throw (string-split val #\,))))
-
-        ;; It's an error to give BYHOUR and smaller for pure dates.
-        ;; 3.3.10. p 41
-        (quick-case (string->symbol key)
-          (UNTIL (set (until o) date))
-
-          (COUNT    (<= 0 num) => (set (count o) num))
-          (INTERVAL (<= 0 num) => (set (interval o) num))
-
-          (FREQ (memv symb intervals) => (set (freq o) symb))
-          (WKST (memv day weekdays)  => (set (wkst o) day))
-
-          ;; Always positive
-          (BYSECOND (every (lambda (n) (<= 0 n 60)) nums) => (set (bysecond o) nums))
-          (BYMINUTE (every (lambda (n) (<= 0 n 59)) nums) => (set (byminute o) nums))
-          (BYHOUR   (every (lambda (n) (<= 0 n 23)) nums) => (set (byhour   o) nums))
-          (BYMONTH  (every (lambda (n) (<= 1 n 12)) nums) => (set (bymonth  o) nums))
-
-          ;; May be negative
-          (BYDAY (every (lambda (p) (memv (cdr p) weekdays)) days) => (set (byday o) days))
-
-          (BYMONTHDAY (every (lambda (n) (and (!= n 0) (<= -31  n 31)))  nums) => (set (bymonthday o) nums))
-          (BYYEARDAY  (every (lambda (n) (and (!= n 0) (<= -366 n 366))) nums) => (set (byyearday  o) nums))
-          (BYSETPOS   (every (lambda (n) (and (!= n 0) (<= -366 n 366))) nums) => (set (bysetpos   o) nums))
-          (BYWEEKNO   (every (lambda (n) (and (!= n 0) (<= -53  n 53)))  nums) => (set (byweekno   o) nums))
-
-          (else o)))))
-
-   ;; obj
-   (make-recur-rule)
-
-   ;; ((key val) ...)
-   (map (cut string-split <> #\=)
-        (string-split str #\;))))
+  (define result
+    (fold
+     (lambda (kv o)
+       (let ((key (car kv))
+             (val (cadr kv)))
+         (let-lazy
+          ((symb (string->symbol val))
+           ;; NOTE until MUST have the same value type as DTSTART
+           ;; on the object. Idealy we would save that type and
+           ;; check it here. That however is impractical since we
+           ;; might encounter the RRULE field before the DTSTART
+           ;; field.
+           (date (if (= 8 (string-length val))
+                     (parse-ics-date val)
+                     (parse-ics-datetime val)))
+           (day (rfc->datetime-weekday (string->symbol val)))
+           (days (map parse-day-spec (string-split val #\,)))
+           (num  (string->number/throw val))
+           (nums (map string->number/throw (string-split val #\,))))
+
+          ;; It's an error to give BYHOUR and smaller for pure dates.
+          ;; 3.3.10. p 41
+          (case (string->symbol key)
+            ((UNTIL)      (until      o date))
+            ((COUNT)      (count      o num))
+            ((INTERVAL)   (interval   o num))
+            ((FREQ)       (freq       o symb))
+            ((WKST)       (wkst       o day))
+            ((BYSECOND)   (bysecond   o nums))
+            ((BYMINUTE)   (byminute   o nums))
+            ((BYHOUR)     (byhour     o nums))
+            ((BYMONH)     (bymonth    o nums))
+            ((BYDAY)      (byday      o days))
+            ((BYMONTHDAY) (bymonthday o nums))
+            ((BYYEARDAY)  (byyearday  o nums))
+            ((BYSETPOS)   (bysetpos   o nums))
+            ((BYWEEKNO)   (byweekno   o nums))
+            (else o)))))
+
+     ;; obj
+     (recur-rule freq: (@ (vcomponent recurrence internal) freq-placeholder))
+
+     ;; ((key val) ...)
+     (map (cut string-split <> #\=)
+          (string-split str #\;))))
+
+  (when (eq? (@ (vcomponent recurrence internal) freq-placeholder)
+             (freq result))
+    (scm-error 'wrong-type-arg
+               "parse-recurrence-rule"
+               "A valid for `freq' is required, but none supplied"
+               '() #f))
+  result)
-- 
cgit v1.2.3