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
|
(define-module (vcomponent recurrence parse)
#:duplicates (last) ; Replace @var{count}
#:export (parse-recurrence-rule)
#:use-module (srfi srfi-1)
#:use-module (datetime)
#:use-module (datetime util)
#:use-module (srfi srfi-26)
#:use-module (vcomponent recurrence internal)
#:use-module (util)
#:use-module (ice-9 match))
;; @example
;; <weekday> ∈ weekdays
;; <weekdaynum> ::= [[±] <num>] <weekday> ;; +3MO
;; (<weekadynum>, ...)
;; @end example
;;; weekdaynum can contain ±
;;; only used in bywdaylist
;;; only present with by BYDAY
;; Returns a pair, where the @code{car} is the offset
;; and @code{cdr} is the day symbol.
;; The @code{car} may be @code{#f}.
;; str → (<num> . <symb>)
(define (parse-day-spec str)
(let* ((numerical-characters (append '(#\+ #\-) (map integer->char (iota 10 #x30))))
(numbers letters (span (cut memv <> numerical-characters)
(string->list str))))
(cons (string->number (list->string numbers))
(apply symbol letters))))
(define-macro (quick-case key . cases)
(let ((else-clause (or (assoc-ref cases 'else)
'(error "Guard failed"))))
`(case ,key
,@(map (match-lambda
((key guard '=> body ...)
`((,key) (if (not ,guard)
(begin ,@else-clause)
(begin ,@body))))
((key body ...)
`((,key) (begin ,@body)))
(('else body ...)
`(else ,@body)))
cases))))
;; RFC 5545, Section 3.3.10. Recurrence Rule, states that the UNTIL value MUST have
;; the same type as the DTSTART of the event (date or datetime). I have seen events
;; in the wild which didn't follow this. I consider that an user error.
(define* (parse-recurrence-rule str optional: (datetime-parser parse-ics-datetime))
(fold
(lambda (kv o)
(let* (((key val) kv))
(let-lazy
((symb (string->symbol val))
(date (datetime-parser val))
(days (map parse-day-spec (string-split val #\,)))
(num (string->number val))
(nums (map string->number (string-split val #\,))))
;; TODO I think it's an error to give BYHOUR and under for dates which aren't datetimes
(quick-case (string->symbol key)
(UNTIL (set! (until o) date))
(COUNT (<= 0 num) => (set! (count o) num))
(INTERVAL (<= 0 num) => (set! (interval o) num))
(FREQ (memv symb intervals) => (set! (freq o) symb))
(WKST (memv symb weekdays) => (set! (wkst o) symb))
;; Always positive
(BYSECOND (every (lambda (n) (<= 0 n 60)) nums) => (set! (bysecond o) nums))
(BYMINUTE (every (lambda (n) (<= 0 n 59)) nums) => (set! (byminute o) nums))
(BYHOUR (every (lambda (n) (<= 0 n 23)) nums) => (set! (byhour o) nums))
(BYMONTH (every (lambda (n) (<= 1 n 12)) nums) => (set! (byweekno o) nums))
;; May be negative
(BYDAY (every (lambda (p) (memv (cdr p) weekdays)) days) => (set! (byday o) days))
(BYMONTHDAY (every (lambda (n) (and (!= n 0) (<= -31 n 31))) nums) => (set! (bymonthday o) nums))
(BYYEARDAY (every (lambda (n) (and (!= n 0) (<= -366 n 366))) nums) => (set! (byyearday o) nums))
(BYSETPOS (every (lambda (n) (and (!= n 0) (<= -366 n 366))) nums) => (set! (bysetpos o) nums))
(BYWEEKNO (every (lambda (n) (and (!= n 0) (<= -53 n 53))) nums) => (set! (byweekno o) nums))
(else o)))))
;; obj
(make-recur-rule (interval 1) (wkst 'MO))
;; ((key val) ...)
(map (cut string-split <> #\=)
(string-split str #\;))))
|