Move timespec and recur-rule to new object system.

4 files changed, 133 insertions, 148 deletions

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)