blob: 84025d2f4b2603204a74c6360642c1bc59822446 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
|
(define-module (vcomponent recurrence generate)
#:use-module (srfi srfi-19) ; Datetime
#:use-module (srfi srfi-19 util)
#:use-module (srfi srfi-19 setters)
#:use-module (srfi srfi-26) ; Cut
#:use-module (srfi srfi-41) ; Streams
#:use-module (ice-9 match)
#:use-module (util)
#:use-module (vcomponent base)
#:use-module (vcomponent recurrence internal)
#:use-module (vcomponent recurrence parse)
#:export (generate-recurrence-set)
)
;;; TODO implement
;;; EXDATE and RDATE
;;; EXDATE (3.8.5.1)
;;; comma sepparated list of dates or datetimes.
;;; Can have TZID parameter
;;; Specifies list of dates that the event should not happen on, even
;;; if the RRULE say so.
;;; Can have VALUE field specifiying "DATE-TIME" or "DATE".
;;; RDATE (3.8.5.2)
;;; Comma sepparated list of dates the event should happen on.
;;; Can have TZID parameter.
;;; Can have VALUE parameter, specyfying "DATE-TIME", "DATE" or "PREIOD".
;;; PERIOD (see 3.3.9)
(define (seconds-in freq)
(case freq
((SECONDLY) 1)
((MINUTELY) 60)
((HOURLY) (* 60 60))
((DAILY) (* 60 60 24))
((WEEKLY) (* 60 60 24 7))))
;; Event x Rule → Event
;; TODO My current naïve aproach to simple adding a constant time to an event
;; breaks with time-zones. betwen 12:00 two adjacent days might NOT be 24h.
;; Specifically, 23h or 25h when going between summer and "normal" time.
(define (next-event ev r)
(let ((e (copy-vcomponent ev)))
(let-env ((TZ (and=> (prop (attr* e 'DTSTART) 'TZID) car)))
(let ((d (time-utc->date (attr e 'DTSTART)))
(i (interval r)))
(case (freq r)
((SECONDLY) (mod! (second d) = (+ i)))
((MINUTELY) (mod! (minute d) = (+ i)))
((HOURLY) (mod! (hour d) = (+ i)))
((DAILY) (mod! (day d) = (+ i)))
((WEEKLY) (mod! (day d) = (+ (* i 7))))
((MONTHLY) (mod! (month d) = (+ i)))
((YEARLY) (mod! (year d) = (+ i))))
(set! (zone-offset d)
(zone-offset (time-utc->date (date->time-utc d))))
(set! (attr e 'DTSTART) (date->time-utc d)))
(when (attr e 'DTEND)
(set! (attr e 'DTEND)
(add-duration (attr e 'DTSTART) (attr e 'X-HNH-DURATION)))))
e))
;; BYDAY and the like depend on the freq?
;; Line 7100
;; Table @@ 2430
;;
;; Event x Rule → Bool (continue?)
;; Alternative, monadic solution using <optional>.
;; @example
;; (optional->bool
;; (do (<$> (cut time<=? (attr last 'DTSTART)) (until r))
;; (<$> (negate zero?) (count r))
;; (just #t)))
;; @end example
(define-stream (recur-event-stream event rule-obj)
(stream-unfold
;; Event x Rule → Event
car
;; Event x Rule → Bool (continue?)
(match-lambda
((e r)
(or (and (not (until r)) (not (count r))) ; Never ending
(and=> (count r) (negate zero?)) ; COUNT
(and=> (until r) (cut time<=? (attr e 'DTSTART) <>))))) ; UNTIL
;; Event x Rule → next (Event, Rule)
(match-lambda
((e r)
(list (next-event e r)
(if (count r)
;; Note that this doesn't modify, since r is immutable.
(mod! (count r) 1-)
r ))))
;; Seed
(list event rule-obj)))
(define (generate-recurrence-set event)
;; TODO DURATION might be used for something else, check applicable types
;; TODO Far from all events have DTEND
;; VTIMEZONE's always lack it.
(if (not (attr event 'RRULE))
(stream event)
(begin
(set! (attr event 'X-HNH-DURATION)
(cond [(attr event 'DURATION) => identity]
[(attr event 'DTEND) => (lambda (end)
(time-difference
end (attr event "DTSTART")))]))
(if (attr event "RRULE")
(recur-event-stream event (parse-recurrence-rule (attr event "RRULE")))
;; TODO some events STANDARD and DAYLIGT doesn't have RRULE's, but rather
;; just mention the current part. Handle this
stream-null))))
|
