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/recurrence/generate-alt.scm | 416 -------------------------- 1 file changed, 416 deletions(-) delete mode 100644 module/vcomponent/recurrence/generate-alt.scm (limited to 'module/vcomponent/recurrence/generate-alt.scm') 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)) - -- cgit v1.2.3