From ecb92a54a8c2dce5f60765f3dece4223b9ff856a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Thu, 21 Mar 2019 21:19:50 +0100 Subject: Fixed recurrence code. --- vcalendar/recur.scm | 223 ++-------------------------------------------------- 1 file changed, 7 insertions(+), 216 deletions(-) (limited to 'vcalendar/recur.scm') diff --git a/vcalendar/recur.scm b/vcalendar/recur.scm index 9ae60fb7..3657cae6 100644 --- a/vcalendar/recur.scm +++ b/vcalendar/recur.scm @@ -1,221 +1,12 @@ (define-module (vcalendar recur) - #: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 curried-definitions) #:use-module (vcalendar) - #:use-module (vcalendar datetime) - #:use-module (util) + #:use-module (vcalendar recurrence generate) + #:re-export (generate-recurrence-set) + #:export (repeating?)) - #:export (recur-event repeating?)) - -;; (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> +;; EXDATE is also a property linked to recurense rules +;; but that property alone don't create a recuring event. (define (repeating? ev) "Does this event repeat?" - (attr ev 'RRULE)) - -(define-quick-record recur-rule - freq until count interval bysecond byminute byhour - byday bymonthday byyearday byweekno bymonth bysetpos - wkst) - -(define (build-recur-rules str) - "Takes a RECUR value (string), and returuns a 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)))) - -;;; 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-rule (throw-returnable symb args ...) - (call/cc (lambda (cont) (throw symb cont args ...)))) - -(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))))))))) - -(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 (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-syntax all-in - (syntax-rules () - ((_ var rules ...) - (cut every (lambda (var) (and rules ...)) <>)))) - -(define (!= a b) (not (= a b))) - -(define weekdays - '(SU MO TU WE TH FR SA)) - -(define intervals - '(SECONDLY MINUTELY HOURLY DAILY WEEKLY MONTHLY YEARLY)) - -(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 - ;; ∈ weekdays - ;; ::= [[±] ] ;; +3MO - ;; (, ...) - ;; (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 - ((record-constructor '(interval wkst)) 1 'MO) - - ;; ((key val) ...) - (map (cut string-split <> #\=) - (string-split str #\;)))) - -(define (seconds-in interval) - (case interval - ((SECONDLY) 1) - ((MINUTELY) 60 ) - ((HOURLY) (* 60 60)) - ((DAILY) (* 60 60 24)) - ((WEEKLY) (* 60 60 24 7)))) - -(define (generate-next event rule) - - (when (count rule) - (set! (count rule) - (1- (count rule))) - - (when (zero? (count rule)) - ;; TODO early return - (values '() '()))) - - - (let ((ne (copy-vcomponent event))) ; new event - (cond - - ;; BYDAY and the like depend on the freq? - ;; Line 7100 - ;; Table @ 2430 - - ((memv (freq rule) '(SECONDLY MINUTELY HOURLY DAILY WEEKLY)) - (mod! (attr ne "DTSTART") - (cut add-duration! <> - (make-duration (* (interval rule) - (seconds-in (freq rule))))))) - ((memv (freq rule) '(MONTHLY YEARLY)) - ;; Hur fasen beräkrnar man det här!!!! - ) - (else #f)) - - - ;; Make sure DTSTART is updated before this point - - (and=> (until rule) - (lambda (u) - (when (time