From 2e8870e61ddacff8dbcbe59b26fa1556dd0afc76 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 19 May 2020 23:20:28 +0200 Subject: Move new recurrence generator to generate.scm. --- module/vcomponent/datetime.scm | 2 +- module/vcomponent/recurrence.scm | 2 +- module/vcomponent/recurrence/display/test.scm | 4 +- module/vcomponent/recurrence/generate-alt.scm | 416 -------------------------- module/vcomponent/recurrence/generate.scm | 416 ++++++++++++++++++++++++++ 5 files changed, 420 insertions(+), 420 deletions(-) delete mode 100644 module/vcomponent/recurrence/generate-alt.scm create mode 100644 module/vcomponent/recurrence/generate.scm diff --git a/module/vcomponent/datetime.scm b/module/vcomponent/datetime.scm index fabe3978..28d48361 100644 --- a/module/vcomponent/datetime.scm +++ b/module/vcomponent/datetime.scm @@ -109,7 +109,7 @@ Event must have the DTSTART and DTEND attribute set." (define (final-spanned-time event) (if (not ((@ (vcomponent recurrence) repeating?) event)) (or (attr event 'DTEND) (attr event 'DTSTART)) - (let ((final ((@ (vcomponent recurrence generate-alt) final-event-occurence) + (let ((final ((@ (vcomponent recurrence generate) final-event-occurence) event))) (if final (aif (attr event 'DTEND) diff --git a/module/vcomponent/recurrence.scm b/module/vcomponent/recurrence.scm index 28decce7..12f901d2 100644 --- a/module/vcomponent/recurrence.scm +++ b/module/vcomponent/recurrence.scm @@ -1,5 +1,5 @@ (define-module (vcomponent recurrence) - #:use-module (vcomponent recurrence generate-alt) + #:use-module (vcomponent recurrence generate) #:use-module (vcomponent recurrence parse) #:use-module (vcomponent recurrence internal) #:re-export (generate-recurrence-set diff --git a/module/vcomponent/recurrence/display/test.scm b/module/vcomponent/recurrence/display/test.scm index e369eda4..71a049da 100644 --- a/module/vcomponent/recurrence/display/test.scm +++ b/module/vcomponent/recurrence/display/test.scm @@ -5,7 +5,7 @@ (use-modules (vcomponent recurrence display) (vcomponent recurrence parse) - (vcomponent recurrence generate-alt) + (vcomponent recurrence generate) (vcomponent) (datetime) (datetime util) @@ -25,7 +25,7 @@ (attr comp 'RRULE)) (map (lambda (d) (datetime->string d "~a ~1 ~3")) (stream->list - 10 ((@@ (vcomponent recurrence generate-alt) rrule-instances) + 10 ((@@ (vcomponent recurrence generate) rrule-instances) comp))))))) diff --git a/module/vcomponent/recurrence/generate-alt.scm b/module/vcomponent/recurrence/generate-alt.scm deleted file mode 100644 index 1d32d793..00000000 --- a/module/vcomponent/recurrence/generate-alt.scm +++ /dev/null @@ -1,416 +0,0 @@ -(define-module (vcomponent recurrence generate-alt) - :export (generate-recurrence-set) - :use-module (util) - :use-module (util exceptions) - :use-module (srfi srfi-1) - :use-module (srfi srfi-26) - :use-module (srfi srfi-41) - :use-module (srfi srfi-41 util) - :use-module (vcomponent base) - :use-module (vcomponent recurrence internal) - :use-module (vcomponent recurrence parse) - - :use-module (datetime) - :use-module (datetime util) - :use-module (ice-9 curried-definitions) ) - - - - - - -;; a → b → (a . b) -(define ((con x) y) - (cons x y)) - -(eval-when (expand compile eval) - (define (stx->bystx symbol str-transformer) - (->> symbol - symbol->string - str-transformer - (string-append (str-transformer "by")) - string->symbol)) - - (define (by-proc symbol) - (stx->bystx symbol string-downcase)) - - (define (by-symb symbol) - (stx->bystx symbol string-upcase)) - - (use-modules (ice-9 match)) - - (define (make-extender-or-limiter extender? rr cases) - `(case (freq ,rr) - ,@(map (match-lambda - [(key '|| cc ...) - `((,key) - (filter - identity - (list - ,@(map (label self - (match-lambda - [('unless pred field) - `(let ((yearday (,(by-proc 'yearday) ,rr)) - (monthday (,(by-proc 'monthday) ,rr))) - ,(if pred #f - (it field)))] - [field - `(and=> (,(by-proc field) ,rr) - ,(if extender? - `(cut map (con (quote ,(by-symb field))) - <>) - `(con (quote ,(by-symb field)))))])) - cc))))]) - cases))) - - (define-macro (make-extenders rr . cases) - `(apply cross-product ,(make-extender-or-limiter #t rr cases))) - - (define-macro (make-limiters rr . cases) - (make-extender-or-limiter #f rr cases))) - - - -;; rrule → (list extension-rule) -(define (all-extenders rrule) - (make-extenders - rrule - [YEARLY || month weekno yearday monthday (unless (or yearday monthday) day) - hour minute second] - [MONTHLY || monthday (unless monthday day) hour minute second] - [WEEKLY || day hour minute second] - [DAILY || hour minute second] - [HOURLY || minute second] - [MINUTELY || second] - [SECONDLY || #| null |#])) - -(define (all-limiters rrule) - (make-limiters - rrule - [YEARLY || day #| setpos |#] - [MONTHLY || month day #|setpos|#] - [WEEKLY || month #|setpos|#] - [DAILY || month monthday day #|setpos|#] - [HOURLY || month yearday monthday day hour #|setpos|#] - [MINUTELY || month yearday monthday day hour minute #|setpos|#] - [SECONDLY || month yearday monthday day hour minute second #|setpos|#] - ;; [else] - )) - -;; next, done -;; (a, a → values a), a, (list a) → values a -(define (branching-fold proc init collection) - (if (null? collection) - init - (call-with-values - (lambda () (proc (car collection) init)) - (lambda vv - (apply values - (concatenate - (map (lambda (v) - (call-with-values - (lambda () (branching-fold proc v (cdr collection))) - list)) - vv))))))) - -;; TODO more special expands (p. 44) -;; TODO which of THESE can be negative -;; (a := (date|datetime)), rrule, extension-rule → a -(define (update date-object rrule extension-rule) - ;; Branching fold instead of regular fold since BYDAY - ;; can extend the recurrence set in weird ways. - (branching-fold - (lambda (rule dt) - (let* (((key . value) rule) - (d (if (date? dt) dt (get-date dt))) - ;; NOTE It's proably an error to give BYHOUR, BYMINUTE, and BYSECOND - ;; rules for a date object. This doesn't warn if those are given, but - ;; instead silently discards them. - (t (as-time dt)) - (to-dt (lambda (o) - (if (date? dt) - (cond [(date? o) o] - [(time? o) d] - [else (error "faoeuhtnsaoeu htnaoeu" )]) - (cond [(date? o) (datetime date: o time: t tz: (get-timezone dt))] - [(time? o) (datetime date: d time: o tz: (get-timezone dt))] - [else (error "faoeuhtnsaoeu htnaoeu" )]))))) - (case key - [(BYMONTH) - (if (and (eq? 'YEARLY (freq rrule)) - (byday rrule) - (not (or (byyearday rrule) - (bymonthday rrule)))) - (valued-map - to-dt - (concatenate - (map (lambda (wday) - (all-wday-in-month - wday (set (month d) value))) - (map cdr (byday rrule))))) - - ;; else - (to-dt (set (month d) value)))] - - [(BYDAY) - (let* (((offset . value) value)) - (case (freq rrule) - [(WEEKLY) - ;; set day to that day in the week which d lies within - (to-dt (date+ (start-of-week d (wkst rrule)) - ;; TODO check that this actually is the correct calculation - (date day: (modulo (- value (wkst rrule)) - 7))))] - - [(MONTHLY) - (let* ((instances (all-wday-in-month value d))) - (catch 'out-of-range - (lambda () - (cond [(eqv? #f offset) - ;; every of that day in this month - (valued-map to-dt instances)] - - [(positive? offset) - (to-dt (list-ref instances (1- offset)))] - - [(negative? offset) - (to-dt (list-ref (reverse instances) - (1- (- offset))))])) - - (lambda (err proc fmt args . rest) - (warning "BYDAY out of range for MONTHLY. - Possibly stuck in infinite loop") - dt)))] - - ;; see Note 2, p. 44 - [(YEARLY) - (cond - - ;; turns it into a limiter - [(or (byyearday rrule) (bymonthday rrule)) - dt] - - ;; this leads to duplicates in the output - [(or (byweekno rrule) (bymonth rrule)) - ;; Handled under BYWEEKNO & BYMONTH respectively - dt] - - [else - (let ((instances (all-wday-in-year - value (start-of-year d)))) - (to-dt - (if (positive? offset) - (list-ref instances (1- offset)) - (list-ref (reverse instances) (1- (- offset))))))]) - ]))] - - [(BYWEEKNO) - (let ((start-of-week (date-starting-week value d (wkst rrule)))) - (if (and (eq? 'YEARLY (freq rrule)) - (byday rrule)) - (stream->values - (stream-map to-dt - (stream-filter - (lambda (d) (memv (week-day d) (map cdr (byday rrule)))) - (stream-take 7 (day-stream start-of-week))))) - - ;; else - (to-dt start-of-week)))] - - [(BYYEARDAY) (to-dt (date+ (start-of-year d) - (date day: (1- value))))] - [(BYMONTHDAY) - (to-dt (set (day d) - (if (positive? value) - value (+ 1 value (days-in-month d)))))] - [(BYHOUR) (to-dt (set (hour t) value))] - [(BYMINUTE) (to-dt (set (minute t) value))] - [(BYSECOND) (to-dt (set (second t) value))] - [else (error "Unrecognized by-extender" key)]))) - date-object - extension-rule)) - - -(define (make-date-increment rr) - (case (freq rr) - [(YEARLY) (datetime date: (date year: (interval rr)))] - [(MONTHLY) (datetime date: (date month: (interval rr)))] - ;; please say that a week has always seven days... - [(WEEKLY) (datetime date: (date day: (* 7 (interval rr))))] - [(DAILY) (datetime date: (date day: (interval rr)))] - [(HOURLY) (datetime time: (time hour: (interval rr)))] - [(MINUTELY) (datetime time: (time minute: (interval rr)))] - [(SECONDLY) (datetime time: (time second: (interval rr)))] - [else (error "Bad freq")])) - -;; NOTE -;; [3.8.5.3. description] -;; The initial DTSTART SHOULD be synchronized with the RRULE. -;; An unsynchronized DTSTART/RRULE results in an undefined recurrence set. - -;; TODO ought to be [rrule, a → (stream a)] where a := (date | datetime) -;; rrule, date → (stream datetime) -(define-stream (extend-recurrence-set rrule base-date) - (stream-append - ;; If no BY-rules are present just add the base-date to the set. - ;; NOTE a possible alternative version (which would probably be better) - ;; would be to always add the base-date to the set, and make sure that the - ;; updated date ≠ base-date - ;; A third alternative would be to add a by rule for the current type. for example: - ;; FREQ=MONTHLY => BYMONTHDAY=(day base-date) - (if (null? (all-extenders rrule)) - (stream base-date) - (list->stream - (sort* - (concatenate - (map (lambda (ext) - (call-with-values (lambda () (update base-date rrule ext)) - list)) - (all-extenders rrule))) - (if (date? base-date) date< datetime<)))) - (extend-recurrence-set - rrule - (if (date? base-date) - (date+ base-date (get-date (make-date-increment rrule))) - (datetime+ base-date (make-date-increment rrule)))))) - -(define ((month-mod d) value) - (if (positive? value) - value (+ value 1 (days-in-month d)))) - -;; returns a function which takes a datetime and is true -;; if the datetime is part of the reccurrence set, and -;; false otherwise. -;; -;; TODO how many of these can take negative numbers? -;; -;; limiters → (a → bool) -(define (limiters->predicate limiters) - (lambda (dt) - (let loop ((remaining limiters)) - (if (null? remaining) - #t - (let* (((key . values) (car remaining)) - (t (as-time dt)) - (d (if (date? dt) dt (get-date dt)))) - (and (case key - [(BYMONTH) (memv (month d) values)] - [(BYMONTHDAY) (memv (day d) (map (month-mod d) values))] - [(BYYEARDAY) (memv (year-day d) values)] - ;; TODO special cases? - [(BYDAY) (memv (week-day d) (map cdr values))] - [(BYHOUR) (memv (hour t) values)] - [(BYMINUTE) (memv (minute t) values)] - [(BYSECOND) (memv (second t) values)] - ;; TODO - ;; [(BYSETPOS)] - [else - (error "Unknown by-limiter")]) - (loop (cdr remaining)))))))) - - -(define-stream (limit-recurrence-set rrule date-stream) - ;; TODO BYSETPOS - (stream-filter - ;; filter inlavid datetimes (feb 30, times droped due to zone-shift, ...) - (lambda (dt) - (let ((d (as-date dt)) - (t (as-time dt))) - (and (<= 0 (hour t) 23) - (<= 0 (minute t) 59) - (<= 0 (second t) 60) - (<= 1 (month d) 12) - (<= 1 (day d) (days-in-month d))))) - (stream-filter - (limiters->predicate (all-limiters rrule)) - date-stream))) - -(define-stream (generate-posibilities rrule base-date) - (limit-recurrence-set - rrule - (extend-recurrence-set - rrule base-date))) - -(define-stream (rrule-instances event) - (define rrule (attr event 'RRULE)) - - ;; 3.8.5.1 exdate are evaluated AFTER rrule (and rdate) - (let ((date-stream (stream-remove - (aif (attr* event 'EXDATE) - (cut member <> (map value it)) - (const #f)) - ;; Some expanders can produce dates before our start time. - ;; For example FREQ=WEEKLY;BYDAY=MO where DTSTART is - ;; anything after monday. This filters these out. - (stream-drop-while - (lambda (d) (date/-time< d (attr event 'DTSTART))) - (generate-posibilities rrule (attr event 'DTSTART))) - ;; TODO ideally I should merge the limited recurrence set - ;; with the list of rdates here. However, I have never - ;; sen an event with an RDATE attribute, so I wont worry - ;; about it for now. - ;; (stream-merge (list->stream (#|rdate's|#)) - ))) - (cond [(count rrule) => (lambda (c) (stream-take c date-stream))] - [(until rrule) => (lambda (end) (stream-take-while - (cut (if (date? (attr event 'DTSTART)) - date<= datetime<=) <> end) - date-stream))] - [else date-stream]))) - - -(define-public (final-event-occurence event) - (define rrule (parse-recurrence-rule - (attr event 'RRULE) - (if (date? (attr event 'DTSTART)) - parse-ics-date parse-ics-datetime))) - - (if (or (count rrule) (until rrule)) - (let ((instances (rrule-instances event))) - (stream-ref instances (1- (stream-length instances)))) - #f)) - - -(define (generate-recurrence-set base-event) - - - (define duration - ;; NOTE DTEND is an optional field. - (let ((end (attr base-event 'DTEND))) - (if end - (if (date? end) - (date-difference end (attr base-event 'DTSTART)) - (datetime-difference end (attr base-event 'DTSTART))) - #f))) - - (define rrule-stream (rrule-instances base-event)) - - (stream-map - (aif (attr base-event 'X-HNH-ALTERNATIVES) - (lambda (dt) - (aif (hash-ref it dt) - it ; RECURRENCE-ID objects come with their own DTEND - (let ((ev (copy-vcomponent base-event))) - (set! (attr ev 'DTSTART) dt) - (when duration - ;; p. 123 (3.8.5.3 Recurrence Rule) - ;; specifies that the DTEND should be updated to match how the - ;; initial dtend related to the initial DTSTART. It also notes - ;; that an event of 1 day in length might be longer or shorter - ;; than 24h depending on timezone shifts. - (set! (attr ev 'DTEND) ((cond [(date? dt) date+] - [(datetime? dt) datetime+] - [else (error "Bad type")]) - dt duration))) - ev))) - (lambda (dt) - (let ((ev (copy-vcomponent base-event))) - (set! (attr ev 'DTSTART) dt) - (when duration - (set! (attr ev 'DTEND) ((cond [(date? dt) date+] - [(datetime? dt) datetime+] - [else (error "Bad type")]) - dt duration))) - ev))) - rrule-stream)) - diff --git a/module/vcomponent/recurrence/generate.scm b/module/vcomponent/recurrence/generate.scm new file mode 100644 index 00000000..b951c5a3 --- /dev/null +++ b/module/vcomponent/recurrence/generate.scm @@ -0,0 +1,416 @@ +(define-module (vcomponent recurrence generate) + :export (generate-recurrence-set) + :use-module (util) + :use-module (util exceptions) + :use-module (srfi srfi-1) + :use-module (srfi srfi-26) + :use-module (srfi srfi-41) + :use-module (srfi srfi-41 util) + :use-module (vcomponent base) + :use-module (vcomponent recurrence internal) + :use-module (vcomponent recurrence parse) + + :use-module (datetime) + :use-module (datetime util) + :use-module (ice-9 curried-definitions) ) + + + + + + +;; a → b → (a . b) +(define ((con x) y) + (cons x y)) + +(eval-when (expand compile eval) + (define (stx->bystx symbol str-transformer) + (->> symbol + symbol->string + str-transformer + (string-append (str-transformer "by")) + string->symbol)) + + (define (by-proc symbol) + (stx->bystx symbol string-downcase)) + + (define (by-symb symbol) + (stx->bystx symbol string-upcase)) + + (use-modules (ice-9 match)) + + (define (make-extender-or-limiter extender? rr cases) + `(case (freq ,rr) + ,@(map (match-lambda + [(key '|| cc ...) + `((,key) + (filter + identity + (list + ,@(map (label self + (match-lambda + [('unless pred field) + `(let ((yearday (,(by-proc 'yearday) ,rr)) + (monthday (,(by-proc 'monthday) ,rr))) + ,(if pred #f + (it field)))] + [field + `(and=> (,(by-proc field) ,rr) + ,(if extender? + `(cut map (con (quote ,(by-symb field))) + <>) + `(con (quote ,(by-symb field)))))])) + cc))))]) + cases))) + + (define-macro (make-extenders rr . cases) + `(apply cross-product ,(make-extender-or-limiter #t rr cases))) + + (define-macro (make-limiters rr . cases) + (make-extender-or-limiter #f rr cases))) + + + +;; rrule → (list extension-rule) +(define (all-extenders rrule) + (make-extenders + rrule + [YEARLY || month weekno yearday monthday (unless (or yearday monthday) day) + hour minute second] + [MONTHLY || monthday (unless monthday day) hour minute second] + [WEEKLY || day hour minute second] + [DAILY || hour minute second] + [HOURLY || minute second] + [MINUTELY || second] + [SECONDLY || #| null |#])) + +(define (all-limiters rrule) + (make-limiters + rrule + [YEARLY || day #| setpos |#] + [MONTHLY || month day #|setpos|#] + [WEEKLY || month #|setpos|#] + [DAILY || month monthday day #|setpos|#] + [HOURLY || month yearday monthday day hour #|setpos|#] + [MINUTELY || month yearday monthday day hour minute #|setpos|#] + [SECONDLY || month yearday monthday day hour minute second #|setpos|#] + ;; [else] + )) + +;; next, done +;; (a, a → values a), a, (list a) → values a +(define (branching-fold proc init collection) + (if (null? collection) + init + (call-with-values + (lambda () (proc (car collection) init)) + (lambda vv + (apply values + (concatenate + (map (lambda (v) + (call-with-values + (lambda () (branching-fold proc v (cdr collection))) + list)) + vv))))))) + +;; TODO more special expands (p. 44) +;; TODO which of THESE can be negative +;; (a := (date|datetime)), rrule, extension-rule → a +(define (update date-object rrule extension-rule) + ;; Branching fold instead of regular fold since BYDAY + ;; can extend the recurrence set in weird ways. + (branching-fold + (lambda (rule dt) + (let* (((key . value) rule) + (d (if (date? dt) dt (get-date dt))) + ;; NOTE It's proably an error to give BYHOUR, BYMINUTE, and BYSECOND + ;; rules for a date object. This doesn't warn if those are given, but + ;; instead silently discards them. + (t (as-time dt)) + (to-dt (lambda (o) + (if (date? dt) + (cond [(date? o) o] + [(time? o) d] + [else (error "faoeuhtnsaoeu htnaoeu" )]) + (cond [(date? o) (datetime date: o time: t tz: (get-timezone dt))] + [(time? o) (datetime date: d time: o tz: (get-timezone dt))] + [else (error "faoeuhtnsaoeu htnaoeu" )]))))) + (case key + [(BYMONTH) + (if (and (eq? 'YEARLY (freq rrule)) + (byday rrule) + (not (or (byyearday rrule) + (bymonthday rrule)))) + (valued-map + to-dt + (concatenate + (map (lambda (wday) + (all-wday-in-month + wday (set (month d) value))) + (map cdr (byday rrule))))) + + ;; else + (to-dt (set (month d) value)))] + + [(BYDAY) + (let* (((offset . value) value)) + (case (freq rrule) + [(WEEKLY) + ;; set day to that day in the week which d lies within + (to-dt (date+ (start-of-week d (wkst rrule)) + ;; TODO check that this actually is the correct calculation + (date day: (modulo (- value (wkst rrule)) + 7))))] + + [(MONTHLY) + (let* ((instances (all-wday-in-month value d))) + (catch 'out-of-range + (lambda () + (cond [(eqv? #f offset) + ;; every of that day in this month + (valued-map to-dt instances)] + + [(positive? offset) + (to-dt (list-ref instances (1- offset)))] + + [(negative? offset) + (to-dt (list-ref (reverse instances) + (1- (- offset))))])) + + (lambda (err proc fmt args . rest) + (warning "BYDAY out of range for MONTHLY. + Possibly stuck in infinite loop") + dt)))] + + ;; see Note 2, p. 44 + [(YEARLY) + (cond + + ;; turns it into a limiter + [(or (byyearday rrule) (bymonthday rrule)) + dt] + + ;; this leads to duplicates in the output + [(or (byweekno rrule) (bymonth rrule)) + ;; Handled under BYWEEKNO & BYMONTH respectively + dt] + + [else + (let ((instances (all-wday-in-year + value (start-of-year d)))) + (to-dt + (if (positive? offset) + (list-ref instances (1- offset)) + (list-ref (reverse instances) (1- (- offset))))))]) + ]))] + + [(BYWEEKNO) + (let ((start-of-week (date-starting-week value d (wkst rrule)))) + (if (and (eq? 'YEARLY (freq rrule)) + (byday rrule)) + (stream->values + (stream-map to-dt + (stream-filter + (lambda (d) (memv (week-day d) (map cdr (byday rrule)))) + (stream-take 7 (day-stream start-of-week))))) + + ;; else + (to-dt start-of-week)))] + + [(BYYEARDAY) (to-dt (date+ (start-of-year d) + (date day: (1- value))))] + [(BYMONTHDAY) + (to-dt (set (day d) + (if (positive? value) + value (+ 1 value (days-in-month d)))))] + [(BYHOUR) (to-dt (set (hour t) value))] + [(BYMINUTE) (to-dt (set (minute t) value))] + [(BYSECOND) (to-dt (set (second t) value))] + [else (error "Unrecognized by-extender" key)]))) + date-object + extension-rule)) + + +(define (make-date-increment rr) + (case (freq rr) + [(YEARLY) (datetime date: (date year: (interval rr)))] + [(MONTHLY) (datetime date: (date month: (interval rr)))] + ;; please say that a week has always seven days... + [(WEEKLY) (datetime date: (date day: (* 7 (interval rr))))] + [(DAILY) (datetime date: (date day: (interval rr)))] + [(HOURLY) (datetime time: (time hour: (interval rr)))] + [(MINUTELY) (datetime time: (time minute: (interval rr)))] + [(SECONDLY) (datetime time: (time second: (interval rr)))] + [else (error "Bad freq")])) + +;; NOTE +;; [3.8.5.3. description] +;; The initial DTSTART SHOULD be synchronized with the RRULE. +;; An unsynchronized DTSTART/RRULE results in an undefined recurrence set. + +;; TODO ought to be [rrule, a → (stream a)] where a := (date | datetime) +;; rrule, date → (stream datetime) +(define-stream (extend-recurrence-set rrule base-date) + (stream-append + ;; If no BY-rules are present just add the base-date to the set. + ;; NOTE a possible alternative version (which would probably be better) + ;; would be to always add the base-date to the set, and make sure that the + ;; updated date ≠ base-date + ;; A third alternative would be to add a by rule for the current type. for example: + ;; FREQ=MONTHLY => BYMONTHDAY=(day base-date) + (if (null? (all-extenders rrule)) + (stream base-date) + (list->stream + (sort* + (concatenate + (map (lambda (ext) + (call-with-values (lambda () (update base-date rrule ext)) + list)) + (all-extenders rrule))) + (if (date? base-date) date< datetime<)))) + (extend-recurrence-set + rrule + (if (date? base-date) + (date+ base-date (get-date (make-date-increment rrule))) + (datetime+ base-date (make-date-increment rrule)))))) + +(define ((month-mod d) value) + (if (positive? value) + value (+ value 1 (days-in-month d)))) + +;; returns a function which takes a datetime and is true +;; if the datetime is part of the reccurrence set, and +;; false otherwise. +;; +;; TODO how many of these can take negative numbers? +;; +;; limiters → (a → bool) +(define (limiters->predicate limiters) + (lambda (dt) + (let loop ((remaining limiters)) + (if (null? remaining) + #t + (let* (((key . values) (car remaining)) + (t (as-time dt)) + (d (if (date? dt) dt (get-date dt)))) + (and (case key + [(BYMONTH) (memv (month d) values)] + [(BYMONTHDAY) (memv (day d) (map (month-mod d) values))] + [(BYYEARDAY) (memv (year-day d) values)] + ;; TODO special cases? + [(BYDAY) (memv (week-day d) (map cdr values))] + [(BYHOUR) (memv (hour t) values)] + [(BYMINUTE) (memv (minute t) values)] + [(BYSECOND) (memv (second t) values)] + ;; TODO + ;; [(BYSETPOS)] + [else + (error "Unknown by-limiter")]) + (loop (cdr remaining)))))))) + + +(define-stream (limit-recurrence-set rrule date-stream) + ;; TODO BYSETPOS + (stream-filter + ;; filter inlavid datetimes (feb 30, times droped due to zone-shift, ...) + (lambda (dt) + (let ((d (as-date dt)) + (t (as-time dt))) + (and (<= 0 (hour t) 23) + (<= 0 (minute t) 59) + (<= 0 (second t) 60) + (<= 1 (month d) 12) + (<= 1 (day d) (days-in-month d))))) + (stream-filter + (limiters->predicate (all-limiters rrule)) + date-stream))) + +(define-stream (generate-posibilities rrule base-date) + (limit-recurrence-set + rrule + (extend-recurrence-set + rrule base-date))) + +(define-stream (rrule-instances event) + (define rrule (attr event 'RRULE)) + + ;; 3.8.5.1 exdate are evaluated AFTER rrule (and rdate) + (let ((date-stream (stream-remove + (aif (attr* event 'EXDATE) + (cut member <> (map value it)) + (const #f)) + ;; Some expanders can produce dates before our start time. + ;; For example FREQ=WEEKLY;BYDAY=MO where DTSTART is + ;; anything after monday. This filters these out. + (stream-drop-while + (lambda (d) (date/-time< d (attr event 'DTSTART))) + (generate-posibilities rrule (attr event 'DTSTART))) + ;; TODO ideally I should merge the limited recurrence set + ;; with the list of rdates here. However, I have never + ;; sen an event with an RDATE attribute, so I wont worry + ;; about it for now. + ;; (stream-merge (list->stream (#|rdate's|#)) + ))) + (cond [(count rrule) => (lambda (c) (stream-take c date-stream))] + [(until rrule) => (lambda (end) (stream-take-while + (cut (if (date? (attr event 'DTSTART)) + date<= datetime<=) <> end) + date-stream))] + [else date-stream]))) + + +(define-public (final-event-occurence event) + (define rrule (parse-recurrence-rule + (attr event 'RRULE) + (if (date? (attr event 'DTSTART)) + parse-ics-date parse-ics-datetime))) + + (if (or (count rrule) (until rrule)) + (let ((instances (rrule-instances event))) + (stream-ref instances (1- (stream-length instances)))) + #f)) + + +(define (generate-recurrence-set base-event) + + + (define duration + ;; NOTE DTEND is an optional field. + (let ((end (attr base-event 'DTEND))) + (if end + (if (date? end) + (date-difference end (attr base-event 'DTSTART)) + (datetime-difference end (attr base-event 'DTSTART))) + #f))) + + (define rrule-stream (rrule-instances base-event)) + + (stream-map + (aif (attr base-event 'X-HNH-ALTERNATIVES) + (lambda (dt) + (aif (hash-ref it dt) + it ; RECURRENCE-ID objects come with their own DTEND + (let ((ev (copy-vcomponent base-event))) + (set! (attr ev 'DTSTART) dt) + (when duration + ;; p. 123 (3.8.5.3 Recurrence Rule) + ;; specifies that the DTEND should be updated to match how the + ;; initial dtend related to the initial DTSTART. It also notes + ;; that an event of 1 day in length might be longer or shorter + ;; than 24h depending on timezone shifts. + (set! (attr ev 'DTEND) ((cond [(date? dt) date+] + [(datetime? dt) datetime+] + [else (error "Bad type")]) + dt duration))) + ev))) + (lambda (dt) + (let ((ev (copy-vcomponent base-event))) + (set! (attr ev 'DTSTART) dt) + (when duration + (set! (attr ev 'DTEND) ((cond [(date? dt) date+] + [(datetime? dt) datetime+] + [else (error "Bad type")]) + dt duration))) + ev))) + rrule-stream)) + -- cgit v1.2.3