From 80b58afc3bb46010f9584fbf04cdc4811c237ab0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 5 Mar 2019 16:57:17 +0100 Subject: Parsing work on recur. --- vcalendar/recur.scm | 229 +++++++++++++++++++--------------------------------- 1 file changed, 83 insertions(+), 146 deletions(-) (limited to 'vcalendar') diff --git a/vcalendar/recur.scm b/vcalendar/recur.scm index 474d228d..572fb020 100644 --- a/vcalendar/recur.scm +++ b/vcalendar/recur.scm @@ -1,155 +1,92 @@ (define-module (vcalendar recur) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-26) - #:use-module (srfi srfi-41) + #:use-module (util)) - #:use-module (vcalendar) - ) - -(define s "FREQ=WEEKLY;UNTIL=20191130") - -(define (generate-kv-pairs str) - (map (cut string-split <> #\=) - (string-split str #\;))) - -(define upstring->symbol (compose string->symbol string-upcase)) - -(define-syntax-rule (ensure key val test) - ((key) - (let ((v val)) - (if (test v) - v - (throw 'bad-value key val)) - ))) - -#; -(let ((key 'FREQ) - (val-base 'HOURLY)) - (case key - (FREQ (upstring->symbol val-base) - (memv <> '(SECONDLY MINUTELY HOURLY DAILY - WEEKLY MONTHLY YEARLY))))) (define-immutable-record-type (make-recur-rules freq until count interval) recur-rule? - (freq get-freq set-freq) - (until get-until set-until) - (count get-count set-count) - (interval get-interval set-interval))) - -(let ((s->n string->number)) - (reduce (lambda (kv rule) - (let ((key (upstring->symbol (car kv))) - (val-base (cadr kv))) - (case key - ((FREQ) - (set-freq rule - (ensure (upstring->symbol val-base) - (cut memv <> - '(SECONDLY MINUTELY HOURLY DAILY - WEEKLY MONTHLY YEARLY))))) - - - ((UNTIL) - (set-until rule (parse-datetime val-base))) - - ((COUNT) (set-count rule (s->n val-base))) - - ((INTERVAL) (set-internal rule (s->n val-base))) - - ((BYSECOND) (let ((s (s->n val-base))) - (<= 0 s 60))) - - ((BYMINUTE) (let ((m (s->n val-base))) - (<= 0 m 59))) - - ((BYHOUR) (let ((h (s->n val-base))) - (<= 0 h 23))) - - #| - ((BYDAY) #; TODO ) - - ((BYMONTHDAY) #; TODO) - ((BYYEARDAY) ) - ((BYWEEKNO) ) - ((BYMONTH) ) - ((BYSETPOS) ) - ((WKST) ) - |# - (else 'err)))) - - (generate-kv-pairs s))) - - - -#| -Each recuring event should be expanded to a stream of all it's occurances. - -The first instance of the event is at DTSTART, -times for following instances are calculating according to the DSL below. - -3.3.10. Recurrence Rule - Value Name: RECUR -|# - - -#| - byseclist = ( seconds *("," seconds) ) - - seconds = 1*2DIGIT ;0 to 60 - - byminlist = ( minutes *("," minutes) ) - - minutes = 1*2DIGIT ;0 to 59 - - byhrlist = ( hour *("," hour) ) - - hour = 1*2DIGIT ;0 to 23 - - bywdaylist = ( weekdaynum *("," weekdaynum) ) - - weekdaynum = [[±] ordwk] weekday - - ordwk = 1*2DIGIT ;1 to 53 - - weekday = "SU" / "MO" / "TU" / "WE" / "TH" / "FR" / "SA" - ;Corresponding to SUNDAY, MONDAY, TUESDAY, WEDNESDAY, THURSDAY, - ;FRIDAY, and SATURDAY days of the week. - - - -Desruisseaux Standards Track [Page 39] - -RFC 5545 iCalendar September 2009 - - - bymodaylist = ( monthdaynum *("," monthdaynum) ) - - monthdaynum = [±] ordmoday - - ordmoday = 1*2DIGIT ;1 to 31 - - byyrdaylist = ( yeardaynum *("," yeardaynum) ) - - yeardaynum = [±] ordyrday - - ordyrday = 1*3DIGIT ;1 to 366 - - bywknolist = ( weeknum *("," weeknum) ) - - weeknum = [±] ordwk - - bymolist = ( monthnum *("," monthnum) ) - - monthnum = 1*2DIGIT ;1 to 12 - - bysplist = ( setposday *("," setposday) ) - - setposday = yeardaynum - - - -|# + (freq get-freq set-freq) + (until get-until set-until) + (count get-count set-count) + (interval get-interval set-interval)) + + +;; (build-recur-rules "FREQ=HOURLY") ; => #< freq: HOURLY until: #f count: #f interval: #f> +;; (build-recur-rules "FREQ=HOURLY;COUNT=3") ; => #< freq: HOURLY until: #f count: 3 interval: #f> +;; (build-recur-rules "FREQ=ERR;COUNT=3") ; => #< freq: #f until: #f count: 3 interval: #f> +;; (build-recur-rules "FREQ=HOURLY;COUNT=err") ; => #< freq: HOURLY until: #f count: #f interval: #f> +;; (build-recur-rules "FREQ=HOURLY;COUNT=-1") ; => #< freq: HOURLY until: #f count: #f interval: #f> + +(define (build-recur-rules str) + (catch-let + (lambda () (%build-recur-rules str)) + + ((unknown-key + (lambda (err cont obj key . rest) + (format #t "ERR Invalid key [~a] while parsing recurence rule, ignoring.~%" key) + (cont obj))) + + (unfulfilled-constraint + (lambda (err cont obj key val . rest) + (let ((default-value (case key + ((INTERVAL) 1) + (else #f)))) + (format #t "ERR Value [~a] doesn't fulfill constraint of type [~a], defauting to [~a].~%" + val key default-value) + (cont default-value)))) + + (invalid-value + (lambda (err cont obj key val . rest) + (format #t "ERR Invalid value [~a] for key [~a], ignoring.~%" val key) + (cont obj)))))) + +(define (string->number-list val delim) + (map string->number (string-split val delim))) + +(define (%build-recur-rules str) + (fold-lists + (lambda ((key val) obj) + (quick-case (string->symbol key) obj + (FREQ (string->symbol val) (cut memv <> '(SECONDLY MINUTELY HOURLY DAILY WEEKLY MONTHLY YEARLY))) + (UNTIL (string->date val) identity) + (COUNT (string->number val) (cut <= 0 <>)) + (INTERVAL (string->number val) (cut <= 0 <>)) + (BYSECOND (string->number-list val #\,) (cut every (cut <= 0 <> 60) <>)) + (BYMINUTE (string->number-list val #\,) (cut every (cut <= 0 <> 59) <>)) + (BYHOUR (string->number-list val #\,) (cut every (cut <= 0 <> 23) <>)) + )) + (make-recur-rules #f #f #f 1) + (map (cut string-split <> #\=) + (string-split str #\;)))) + + +;;; 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-helper obj parent-expr expr ) + "Helper function for quick-case below" + (with-syntax ((obj (datum->syntax parent-expr obj))) + (syntax-case expr () + ((key val proc) + (with-syntax ((setter (datum->syntax parent-expr (make-setter (syntax->datum (syntax key)))))) + #'((key) + (cond ((not val) (call/cc (lambda (cont) (throw 'invalid-value cont obj (quote key) val)))) + ((proc val) (setter obj val)) + (else (setter obj (call/cc (lambda (cont) (throw 'unfulfilled-constraint cont obj (quote key) val)))))))))))) + +(define-syntax quick-case + (lambda (x) + (syntax-case x () + ((_ var-key obj (key val proc) ...) + (let* ((make-setter (lambda (symb) (symbol-append 'set- (symbol-downcase symb)))) + (cc (lambda (lst) (map (cut syntax-helper (syntax->datum (syntax obj)) x <>) + lst)))) + #`(case var-key + #,@(cc #'((key val proc) ...)) + (else (call/cc (lambda (cont) (throw 'unknown-key cont obj var-key)))))))))) -- cgit v1.2.3