Remove define-quick-record macros.

4 files changed, 121 insertions, 98 deletions

diff --git a/module/util.scm b/module/util.scm
index d54ad07b..474c7589 100644
--- a/module/util.scm
+++ b/module/util.scm
@@ -100,49 +100,6 @@
 
 
 
-;;; Helper macros to make define-quick-record better
-
-(define (class-name symb) (symbol-append '< symb '>))
-(define (constructor symb) (symbol-append 'make- symb))
-(define (pred symb) (symbol-append symb '?))
-
-(define (getter name symb) (symbol-append 'get- name '- symb))
-(define* (setter name symb #:optional bang?)
-  (symbol-append 'set- name '- symb (if bang? '! (symbol))))
-
-(define (%define-quick-record internal-define bang? name fields)
-  (let ((symb (gensym)))
-    `((,internal-define ,(class-name name)
-                        (,(constructor name) ,@fields)
-                        ,(pred name)
-                        ,@(map (lambda (f) `(,f ,(getter f symb) ,(setter f symb bang?)))
-                               fields))
-      ,@(map (lambda (f) `(define ,f (make-procedure-with-setter
-                                 ,(getter f symb) ,(setter f symb bang?))))
-             fields))))
-
-;;; Creates srfi-9 define{-immutable,}-record-type declations.
-;;; Also creates srfi-17 accessor ((set! (access field) value))
-
-;;; TODO allow extra properties to be sent to this macro,
-;;; such as @var{:muttable} or @var{:immutable}
-
-(define-macro (define-quick-record name . fields)
-  (let ((public-fields  (or (assoc-ref fields #:public)  '()))
-        (private-fields (or (assoc-ref fields #:private) '()))
-        (printer (and=> (assoc-ref fields #:printer) car)))
-    `(begin
-       ,@(%define-quick-record '(@ (srfi srfi-9 gnu) define-immutable-record-type)
-                               #f name
-                               (append public-fields private-fields))
-       (when ,printer
-         ((@ (srfi srfi-9 gnu) set-record-type-printer!)
-          ,(class-name name) ,printer))
-       ,@(map (lambda (field) `(export ,field))
-              public-fields))))
-
-
-
 ;; Replace let* with a version that can bind from lists.
 ;; Also supports SRFI-71 (extended let-syntax for multiple values)
 ;; @lisp
diff --git a/module/vcomponent/recurrence/generate.scm b/module/vcomponent/recurrence/generate.scm
index c03a935a..1ff3cc49 100644
--- a/module/vcomponent/recurrence/generate.scm
+++ b/module/vcomponent/recurrence/generate.scm
@@ -128,8 +128,7 @@
      ((e r)
       (list (next-event e r)
             (if (count r)
-                ;; Note that this doesn't modify, since r is immutable.
-                (mod! (count r) 1-)
+                (set (count r) = (- 1))
                 r ))))
 
    ;; Seed
diff --git a/module/vcomponent/recurrence/internal.scm b/module/vcomponent/recurrence/internal.scm
index cb00cd3d..69d0469a 100644
--- a/module/vcomponent/recurrence/internal.scm
+++ b/module/vcomponent/recurrence/internal.scm
@@ -4,6 +4,8 @@
   #:use-module (srfi srfi-88)           ; better keywords
   #:use-module ((vcomponent base) :select (attr))
   #:use-module (datetime util)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
   #:use-module (util)
   )
 
@@ -14,46 +16,111 @@
   (or (attr ev 'RRULE)
       (attr ev 'RDATE)))
 
+;; weekday := [0, 7)
+
 ;; Immutable, since I easily want to be able to generate the recurence set for
 ;; the same event multiple times.
-(define-quick-record recur-rule
-  (public: freq until count interval bysecond byminute byhour
-           byday bymonthday byyearday byweekno bymonth bysetpos
-           wkst)
-
-  ;; TODO make this part of define-quick-record.
-  ;; Only "hard" part would be to provide type hints for fields for
-  ;; string conversions.
-  (printer:
-   (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)
-                     (display " " port)
-                     (display field port)
-                     (display "=" port)
-                     (display
-                      (case field
-                        ;; TODO check over date/time/datetime here
-                        ;; ((until) ((@ (datetime util) time->string) it))
-                        (else it))
-                      port)))
-         (display ">" port))))))
-
-;; @begin{example}
-;; (mkrule (freq HOURLY) (wkst MO) (interval 1))
-;; @end
-;; TODO field validation here, like in parse-recurrence-rule.
-;; NOTE this shadows built in constructor generated in define-quick-record
-(define-syntax make-recur-rule
-  (syntax-rules ()
-    ((_ (key val) ...)
-     ((record-constructor <recur-rule> (quote (key ...)))
-      val ...))))
+(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
+  )
+
+(export freq until count interval bysecond byminute byhour
+        byday bymonthday byyearday byweekno bymonth bysetpos
+        wkst)
+
+(define*-public (make-recur-rule
+                 key:
+                 freq until count interval bysecond byminute byhour
+                 byday bymonthday byyearday byweekno bymonth bysetpos
+                 wkst)
+  (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)
+                   (display " " port)
+                   (display field port)
+                   (display "=" port)
+                   (display
+                    (case field
+                      ;; TODO check over date/time/datetime here
+                      ;; ((until) ((@ (datetime util) time->string) it))
+                      (else it))
+                    port)))
+       (display ">" port)))))
+
+
+(define (byday->string pair)
+  (let* (((off . day) pair))
+    (string-append
+     (or (and=> off number->string) "")
+     (string-upcase
+      (week-day-name day 2
+                     locale: (make-locale (list LC_TIME) "C"))))))
+
+(use-modules (ice-9 i18n)
+             (datetime)
+             (srfi srfi-1))
+
+(define-public (recur-rule->rrule-string rrule)
+  (define (get f)
+    ((record-accessor <recur-rule> f) rrule))
+  (string-join
+   (filter-map
+    (lambda (field)
+      (if (not (get field))
+          #f
+          (string-append
+           (string-upcase (symbol->string field))
+           "="
+           (case field
+             [(wkst)
+              (string-upcase
+               (week-day-name (get field) 2
+                              locale: (make-locale (list LC_TIME) "C")))]
+             [(byday)
+              (string-join (map byday->string (get field)) ",")]
+             [(freq count interval)
+              (format #f "~a" (get field))]
+             [(until)
+              (let ((o (get field)))
+                (if (date? o)
+                    (date->string o "~Y~m~d")
+                    (datetime->string o "~Y~m~dT~H~M~S~Z")
+                    ))]
+             [else (format #f "~{~a~^,~}" (get field))]))))
+    (record-type-fields <recur-rule>))
+   ";"))
+
+
+
 
 (define-public weekdays
   (weekday-list sun))
diff --git a/module/vcomponent/recurrence/parse.scm b/module/vcomponent/recurrence/parse.scm
index a2221660..b044aae1 100644
--- a/module/vcomponent/recurrence/parse.scm
+++ b/module/vcomponent/recurrence/parse.scm
@@ -83,32 +83,32 @@
 
         ;; TODO I think it's an error to give BYHOUR and under for dates which aren't datetimes
         (quick-case (string->symbol key)
-          (UNTIL (set! (until o) date))
+          (UNTIL (set (until o) date))
 
-          (COUNT    (<= 0 num) => (set! (count o) num))
-          (INTERVAL (<= 0 num) => (set! (interval o) num))
+          (COUNT    (<= 0 num) => (set (count o) num))
+          (INTERVAL (<= 0 num) => (set (interval o) num))
 
-          (FREQ (memv symb intervals) => (set! (freq o) symb))
-          (WKST (memv symb weekdays)  => (set! (wkst o) (cdar days)))
+          (FREQ (memv symb intervals) => (set (freq o) symb))
+          (WKST (memv symb weekdays)  => (set (wkst o) (cdar days)))
 
           ;; 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))
+          (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))
+          (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))
+          (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 (interval 1) (wkst mon))
+   (make-recur-rule interval: 1 wkst: mon)
 
    ;; ((key val) ...)
    (map (cut string-split <> #\=)