diff options
Diffstat (limited to 'module/vcomponent/recurrence')
-rw-r--r-- | module/vcomponent/recurrence/generate.scm | 137 | ||||
-rw-r--r-- | module/vcomponent/recurrence/internal.scm | 45 | ||||
-rw-r--r-- | module/vcomponent/recurrence/parse.scm | 131 |
3 files changed, 313 insertions, 0 deletions
diff --git a/module/vcomponent/recurrence/generate.scm b/module/vcomponent/recurrence/generate.scm new file mode 100644 index 00000000..9b611ecd --- /dev/null +++ b/module/vcomponent/recurrence/generate.scm @@ -0,0 +1,137 @@ +(define-module (vcomponent recurrence generate) + #:use-module (srfi srfi-19) ; Datetime + #:use-module (srfi srfi-19 util) + #:use-module (srfi srfi-19 setters) + #:use-module (srfi srfi-26) ; Cut + #:use-module (srfi srfi-41) ; Streams + #:use-module (ice-9 match) + + #:use-module (util) + #:use-module (vcomponent) + #:use-module (vcomponent timezone) + #:use-module (vcomponent recurrence internal) + #:use-module (vcomponent recurrence parse) + + #:export (generate-recurrence-set) + ) + +;;; TODO implement +;;; EXDATE and RDATE + +;;; EXDATE (3.8.5.1) +;;; comma sepparated list of dates or datetimes. +;;; Can have TZID parameter +;;; Specifies list of dates that the event should not happen on, even +;;; if the RRULE say so. +;;; Can have VALUE field specifiying "DATE-TIME" or "DATE". + +;;; RDATE (3.8.5.2) +;;; Comma sepparated list of dates the event should happen on. +;;; Can have TZID parameter. +;;; Can have VALUE parameter, specyfying "DATE-TIME", "DATE" or "PREIOD". +;;; PERIOD (see 3.3.9) + +(define (seconds-in freq) + (case freq + ((SECONDLY) 1) + ((MINUTELY) 60) + ((HOURLY) (* 60 60)) + ((DAILY) (* 60 60 24)) + ((WEEKLY) (* 60 60 24 7)))) + +;; Event x Rule → Event +;; TODO My current naïve aproach to simple adding a constant time to an event +;; breaks with time-zones. betwen 12:00 two adjacent days might NOT be 24h. +;; Specifically, 23h or 25h when going between summer and "normal" time. +(define (next-event ev r) + (let* ((e (copy-vcomponent ev)) + (d (time-utc->date + (attr e 'DTSTART) + (if (prop (attr* ev 'DTSTART) 'TZID) + (get-tz-offset e) + 0)))) + + (let ((i (interval r))) + (case (freq r) + ((SECONDLY) (mod! (second d) = (+ i))) + ((MINUTELY) (mod! (minute d) = (+ i))) + ((HOURLY) (mod! (hour d) = (+ i))) + ((DAILY) (mod! (day d) = (+ i))) + ((WEEKLY) (mod! (day d) = (+ (* i 7)))) + ((MONTHLY) (mod! (month d) = (+ i))) + ((YEARLY) (mod! (year d) = (+ i))))) + + (set! (attr e 'DTSTART) + (date->time-utc d)) + + (when (prop (attr* e 'DTSTART) 'TZID) + (let ((of (get-tz-offset e))) + ;; This addition works, but we still get lunch at 13 + (set! (zone-offset d) of))) + + (set! (attr e 'DTSTART) + (date->time-utc d)) + + (when (attr e 'DTEND) + (set! (attr e 'DTEND) + (add-duration (attr e 'DTSTART) (attr e 'DURATION)))) + + ;; Return + e)) + +;; BYDAY and the like depend on the freq? +;; Line 7100 +;; Table @@ 2430 +;; +;; Event x Rule → Bool (continue?) +;; Alternative, monadic solution using <optional>. +;; @example +;; (optional->bool +;; (do (<$> (cut time<=? (attr last 'DTSTART)) (until r)) +;; (<$> (negate zero?) (count r)) +;; (just #t))) +;; @end example +(define-stream (recur-event-stream event rule-obj) + (stream-unfold + + ;; Event x Rule → Event + car + + ;; Event x Rule → Bool (continue?) + (match-lambda + ((e r) + (or (and (not (until r)) (not (count r))) ; Never ending + (and=> (count r) (negate zero?)) ; COUNT + (and=> (until r) (cut time<=? (attr e 'DTSTART) <>))))) ; UNTIL + + ;; Event x Rule → next (Event, Rule) + (match-lambda + ((e r) + (list (next-event e r) + (if (count r) + ;; Note that this doesn't modify, since r is immutable. + (mod! (count r) 1-) + r )))) + + ;; Seed + (list event rule-obj))) + + +(define (generate-recurrence-set event) + ;; TODO DURATION might be used for something else, check applicable types + ;; TODO Far from all events have DTEND + ;; VTIMEZONE's always lack it. + (if (not (attr event 'RRULE)) + (stream event) + (begin + (when (and (attr event 'DTEND) + (not (attr event 'DURATION))) + (set! (attr event "DURATION") + (time-difference + (attr event "DTEND") + (attr event "DTSTART")))) + (if (attr event "RRULE") + (recur-event-stream event (parse-recurrence-rule (attr event "RRULE"))) + ;; TODO some events STANDARD and DAYLIGT doesn't have RRULE's, but rather + ;; just mention the current part. Handle this + stream-null)))) diff --git a/module/vcomponent/recurrence/internal.scm b/module/vcomponent/recurrence/internal.scm new file mode 100644 index 00000000..f7095d1d --- /dev/null +++ b/module/vcomponent/recurrence/internal.scm @@ -0,0 +1,45 @@ +(define-module (vcomponent recurrence internal) + #:use-module (util) + #:use-module ((ice-9 optargs) #:select (define*-public)) + #:use-module (srfi srfi-88) + #:export (make-recur-rule + weekdays intervals)) + +;; 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)) + +(define (make-recur-rule interval wkst) + ((record-constructor <recur-rule> '(interval wkst)) interval wkst)) + +;; TODO make this part of define-quick-record. +;; Only "hard" part would be to provide type hints for fields for +;; string conversions. +(define-public (format-recur-rule r) + (define (a f) + ((record-accessor <recur-rule> f) r)) + (with-output-to-string + (lambda () + (format #t "#<recur-rule>~%") + (for-each + (lambda (field) + (when (a field) + (format #t " ~8@a: ~a~%" + field + ((case field + ((until) (@ (srfi srfi-19 util) time->string)) + (else identity)) + (a field))))) + (record-type-fields <recur-rule>))))) + +(define*-public (print-recur-rule r #:optional (port (current-output-port))) + (display (format-recur-rule r) port)) + +(define weekdays + '(SU MO TU WE TH FR SA)) + +(define intervals + '(SECONDLY MINUTELY HOURLY DAILY WEEKLY MONTHLY YEARLY)) diff --git a/module/vcomponent/recurrence/parse.scm b/module/vcomponent/recurrence/parse.scm new file mode 100644 index 00000000..7df0e2e6 --- /dev/null +++ b/module/vcomponent/recurrence/parse.scm @@ -0,0 +1,131 @@ +(define-module (vcomponent recurrence parse) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) ; Datetime + #:use-module (srfi srfi-19 util) + #:use-module (srfi srfi-26) + #:use-module ((vcomponent datetime) #:select (parse-datetime)) + #:duplicates (last) ; Replace @var{count} + #:use-module (vcomponent recurrence internal) + #:use-module (util) + #:use-module (exceptions) + #:use-module (ice-9 curried-definitions) + #:export (parse-recurrence-rule)) + + +(define (printerr fmt . args) + (apply format (current-error-port) + fmt args)) + +(define (parse-recurrence-rule str) + (catch-multiple + (lambda () (%build-recur-rules str)) + + [unfulfilled-constraint + (cont obj key val . rest) + (printerr "ERR ~a [~a] doesn't fulfill constraint of type [~a], ignoring~%" + err val key) + (cont #f)] + + [invalid-value + (cont obj key val . rest) + (printerr "ERR ~a [~a] for key [~a], ignoring.~%" + err val key) + (cont #f)])) + +(eval-when (expand) + (define ((handle-case stx obj) key val proc) + (with-syntax ((skey (datum->syntax + stx (symbol-downcase (syntax->datum key))))) + #`((#,key) + (let ((v #,val)) + (cond ((not v) (throw-returnable 'invalid-value #,obj (quote #,key) v)) + ((#,proc #,val) (set! (skey #,obj) v)) + (else (set! (skey #,obj) + (throw-returnable 'unfulfilled-constraint + #,obj (quote #,key) v))))))))) + + +;; A special form of case only useful in parse-recurrence-rules above. +;; Each case is on the form (KEY val check-proc) where: +;; `key` is what should be matched against, and what is used for the setter +;; `val` is the value to bind to the loop object and +;; `check` is something the object must conform to +(define-syntax quick-case + (lambda (stx) + (syntax-case stx () + ((_ var-key obj (key val proc) ...) + #`(case var-key + #,@(map (handle-case stx #'obj) + #'(key ...) + #'(val ...) + #'(proc ...)) + (else obj)))))) + +(define-syntax all-in + (syntax-rules () + ((_ var rules ...) + (cut every (lambda (var) (and rules ...)) <>)))) + +(define (string->number-list val delim) + (map string->number (string-split val delim))) + +(define (string->symbols val delim) + (map string->symbol (string-split val delim))) + +;; @example +;; <weekday> ∈ weekdays +;; <weekdaynum> ::= [[±] <num>] <weekday> ;; +3MO +;; (<weekadynum>, ...) +;; @end example + +;; Returns a pair, where the @code{car} is the offset +;; and @code{cdr} is the day symbol. +;; The @code{car} may be @code{#f}. +(define (parse-day-spec str) + (let* ((numchars (append '(#\+ #\-) (map integer->char (iota 10 #x30)))) + (num symb (span (cut memv <> numchars) + (string->list str)))) + (cons (string->number (list->string num)) + (apply symbol symb)))) + +(define (%build-recur-rules str) + (fold + (lambda (kv obj) + (let* (((key val) kv) + ;; Lazy fields for the poor man. + (symb (lambda () (string->symbol val))) + (date (lambda () (date->time-utc (parse-datetime val)))) + (days (lambda () (map parse-day-spec (string-split val #\,)))) + (num (lambda () (string->number val))) + (nums (lambda () (string->number-list val #\,)))) + (quick-case (string->symbol key) obj + (FREQ (symb) (cut memv <> intervals)) ; Required + (UNTIL (date) identity) + (COUNT (num) (cut <= 0 <>)) + (INTERVAL (num) (cut <= 0 <>)) + (BYSECOND (nums) (all-in n (<= 0 n 60))) + (BYMINUTE (nums) (all-in n (<= 0 n 59))) + (BYHOUR (nums) (all-in n (<= 0 n 23))) + + (BYDAY (days) + (lambda (p*) + (map (lambda (p) + (let* (((num . symb) p)) + (memv symb weekdays))) + p*))) + + (BYMONTHDAY (nums) (all-in n (<= -31 n 31) (!= n 0))) + (BYYEARDAY (nums) (all-in n (<= -366 n 366) (!= n 0))) + (BYWEEKNO (nums) (all-in n (<= -53 n 53) (!= n 0))) + (BYMONTH (nums) (all-in n (<= 1 n 12))) + (BYSETPOS (nums) (all-in n (<= -366 n 366) (!= n 0))) + + (WKST (symb) (cut memv <> weekdays)) + ))) + + ;; obj + (make-recur-rule 1 'MO) + + ;; ((key val) ...) + (map (cut string-split <> #\=) + (string-split str #\;)))) |