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
127
128
129
130
131
|
(define-module (vcomponent recurrence parse)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-19) ; Datetime
#:use-module (srfi srfi-19 util)
#:use-module (srfi srfi-26)
#:use-module ((vcomponent datetime) #:select (parse-datetime))
#:duplicates (last) ; Replace @var{count}
#:use-module (vcomponent recurrence internal)
#:use-module (util)
#:use-module (exceptions)
#:use-module (ice-9 curried-definitions)
#:export (parse-recurrence-rule))
(define (printerr fmt . args)
(apply format (current-error-port)
fmt args))
(define (parse-recurrence-rule str)
(catch-multiple
(lambda () (%build-recur-rules str))
[unfulfilled-constraint
(cont obj key val . rest)
(printerr "ERR ~a [~a] doesn't fulfill constraint of type [~a], ignoring~%"
err val key)
(cont #f)]
[invalid-value
(cont obj key val . rest)
(printerr "ERR ~a [~a] for key [~a], ignoring.~%"
err val key)
(cont #f)]))
(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)))))))))
;; A special form of case only useful in parse-recurrence-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 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-syntax all-in
(syntax-rules ()
((_ var rules ...)
(cut every (lambda (var) (and rules ...)) <>))))
(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)))
;; @example
;; <weekday> ∈ weekdays
;; <weekdaynum> ::= [[±] <num>] <weekday> ;; +3MO
;; (<weekadynum>, ...)
;; @end example
;; Returns a pair, where the @code{car} is the offset
;; and @code{cdr} is the day symbol.
;; The @code{car} may be @code{#f}.
(define (parse-day-spec str)
(let* ((numchars (append '(#\+ #\-) (map integer->char (iota 10 #x30))))
(num symb (span (cut memv <> numchars)
(string->list str))))
(cons (string->number (list->string num))
(apply symbol symb))))
(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 () (date->time-utc (parse-datetime val))))
(days (lambda () (map parse-day-spec (string-split val #\,))))
(num (lambda () (string->number val)))
(nums (lambda () (string->number-list val #\,))))
(quick-case (string->symbol key) obj
(FREQ (symb) (cut memv <> intervals)) ; Required
(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)))
(BYDAY (days)
(lambda (p*)
(map (lambda (p)
(let* (((num . symb) p))
(memv symb weekdays)))
p*)))
(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
(make-recur-rule 1 'MO)
;; ((key val) ...)
(map (cut string-split <> #\=)
(string-split str #\;))))
|
