diff options
Diffstat (limited to 'vcalendar/recurrence')
| -rw-r--r-- | vcalendar/recurrence/generate.scm | 108 | ||||
| -rw-r--r-- | vcalendar/recurrence/internal.scm | 28 | ||||
| -rw-r--r-- | vcalendar/recurrence/parse.scm | 108 |
3 files changed, 244 insertions, 0 deletions
diff --git a/vcalendar/recurrence/generate.scm b/vcalendar/recurrence/generate.scm new file mode 100644 index 00000000..222362fd --- /dev/null +++ b/vcalendar/recurrence/generate.scm @@ -0,0 +1,108 @@ +(define-module (vcalendar recurrence generate) + ;; #:use-module (srfi srfi-1) + ;; #:use-module (srfi srfi-9 gnu) ; Records + #:use-module (srfi srfi-19) ; Datetime + #:use-module (srfi srfi-19 util) + + #:use-module (srfi srfi-26) ; Cut + #:use-module (srfi srfi-41) ; Streams + #:use-module (ice-9 control) ; ? + #:use-module (ice-9 match) + #:use-module (vcalendar) + #:use-module (vcalendar datetime) + #:use-module (util) + + #:use-module (vcalendar recurrence internal) + #:use-module (vcalendar 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 interval) + (case interval + ((SECONDLY) 1) + ((MINUTELY) 60) + ((HOURLY) (* 60 60)) + ((DAILY) (* 60 60 24)) + ((WEEKLY) (* 60 60 24 7)))) + +(define-stream (recur-event-stream event rule-obj) + (stream-unfold + ;; Rule → event + (match-lambda + ((last r) + (let ((e (copy-vcomponent last))) ; new event + ;; TODO + ;; Update DTEND as (add-duration DTSTART DURATINO) + (cond + + ;; BYDAY and the like depend on the freq? + ;; Line 7100 + ;; Table @ 2430 + + ((memv (freq r) '(SECONDLY MINUTELY HOURLY DAILY WEEKLY)) + (mod! (attr e "DTSTART") + (cut add-duration! <> + (make-duration + ;; INTERVAL + (* (interval r) + (seconds-in (freq r))))))) + + ((memv (freq r) '(MONTHLY YEARLY)) + ;; Hur fasen beräkrnar man det här!!!! + #f + ) + + (else #f)) + e))) + + ;; Rule → Bool (#t if continue, #f if stop) + (match-lambda + ((last r) + + ;; (optional->bool + ;; (do (<$> (cut time<=? (attr last 'DTSTART)) (until r)) + ;; (<$> (negate zero?) (count r)) + ;; (just #t))) + + (or (and (not (until r)) (not (count r))) + (and=> (until r) (cut time<=? (attr last 'DTSTART) <>)) ; UNTIL + (and=> (count r) (negate zero?))) ; COUNT + + ) + ) + + ;; Rule → (next) Rule + (match-lambda + ((last r) + ;; Note that this doesn't modify, since r is immutable. + (list last + (if (count r) + (mod! (count r) 1-) + r)))) + (list event rule-obj))) + + +(define (generate-recurrence-set event) + (unless (attr event "DURATION") + (set! (attr event "DURATION") + (time-difference + (attr event "DTEND") + (attr event "DTSTART")))) + (recur-event-stream event (build-recur-rules (attr event "RRULE")))) diff --git a/vcalendar/recurrence/internal.scm b/vcalendar/recurrence/internal.scm new file mode 100644 index 00000000..b62d75c2 --- /dev/null +++ b/vcalendar/recurrence/internal.scm @@ -0,0 +1,28 @@ +(define-module (vcalendar recurrence internal) + #:use-module (util) + #:use-module (srfi srfi-88) + #:export (make-recur-rule + weekdays intervals)) + +;; (list +;; (build-recur-rules "FREQ=HOURLY") +;; (build-recur-rules "FREQ=HOURLY;COUNT=3") +;; (build-recur-rules "FREQ=ERR;COUNT=3") +;; (build-recur-rules "FREQ=HOURLY;COUNT=err") +;; (build-recur-rules "FREQ=HOURLY;COUNT=-1")) + +;; 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)) + +(define weekdays + '(SU MO TU WE TH FR SA)) + +(define intervals + '(SECONDLY MINUTELY HOURLY DAILY WEEKLY MONTHLY YEARLY)) diff --git a/vcalendar/recurrence/parse.scm b/vcalendar/recurrence/parse.scm new file mode 100644 index 00000000..938cfc61 --- /dev/null +++ b/vcalendar/recurrence/parse.scm @@ -0,0 +1,108 @@ +(define-module (vcalendar 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 (vcalendar recurrence internal) + #:use-module (util) + #:use-module (exceptions) + #:use-module (ice-9 curried-definitions) + #:export (build-recur-rules) + + ) + + + +(define (build-recur-rules str) + "Takes a RECUR value (string), and returuns a <recur-rule> object" + (catch #t + (lambda () (%build-recur-rules str)) + (lambda (err cont obj key val . rest) + (let ((fmt (case err + ((unfulfilled-constraint) + "ERR ~a [~a] doesn't fulfill constraint of type [~a], ignoring~%") + ((invalid-value) + "ERR ~a [~a] for key [~a], ignoring.~%") + (else "~a ~a ~a")))) + (format #t fmt err val key)) + (cont obj)))) + +(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 build-recur-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))) + +(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 () (parse-datetime val))) + (num (lambda () (string->number val))) + (nums (lambda () (string->number-list val #\,)))) + (quick-case (string->symbol key) obj + (FREQ (symb) (cut memv <> intervals)) ; Requirek + (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))) + + ;; TODO + ;; <weekday> ∈ weekdays + ;; <weekdaynum> ::= [[±] <num>] <weekday> ;; +3MO + ;; (<weekadynum>, ...) + ;; (BYDAY (string-split val #\,)) + + (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 #\;)))) |