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
|
(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)]))
(define-macro (quick-case key obj . cases)
`(case ,key
,@(map (lambda (c)
(let* (((symb val pred) c))
`((,symb)
(set! (,(symbol-downcase symb) ,obj)
(let ((v ,val))
(if (,pred v) v
(throw-returnable
'unfulfilled-constraint
,obj (quote ,key) ,val)))))))
cases)))
(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))
(let-lazy
((symb (string->symbol val))
(date (date->time-utc (parse-datetime val)))
(days (map parse-day-spec (string-split val #\,)))
(num (string->number val))
(nums (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* (((n . s) p))
(memv s 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 #\;))))
|
