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