diff options
Diffstat (limited to '')
-rw-r--r-- | module/vcomponent/recurrence/internal.scm | 143 |
1 files changed, 105 insertions, 38 deletions
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)) |