(define-module (vcalendar recur) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-26) #:use-module (vcalendar datetime) #:use-module (util) #:export ( build-recur-rules)) (define-immutable-record-type (make-recur-rules freq until count interval bysecond byminute byhour wkst) recur-rule? (freq get-freq set-freq) (until get-until set-until) (count get-count set-count) (interval get-interval set-interval) ; 1 (bysecond get-bysecond set-bysecond) (byminute get-byminute set-byminute) (byhour get-byhour set-byhour) (wkst get-wkst set-wkst) ; MO ) ;; (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 (string->symbols val delim) (map string->symbol (string-split val delim))) (define weekdays '(SU MO TU WE TH FR SA)) ;;; 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 (x) (let ((syntax-helper (lambda (obj parent-expr expr) "Helper function for quick-case below" (with-syntax ((obj (datum->syntax parent-expr obj))) (syntax-case expr () ((key val proc) (let ((make-setter (lambda (symb) (symbol-append 'set- (symbol-downcase symb))))) (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))))))))))))))) (syntax-case x () ((_ var-key obj (key val proc) ...) (let ((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))))))))))) (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 (parse-datetime 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) <>)) ;; TODO implement these ;; (BYDAY) ;; (BYMONTHDAY) ;; (BYYEARDAY) ;; (BYWEEKNO) ;; (BYMONTH) ;; (BYSETPOS) (WKST (string->symbol val) (cut memv <> weekdays)) )) ((record-constructor '(interval wkst)) 1 'MO) (map (cut string-split <> #\=) (string-split str #\;))))