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
|
(define-module (vcalendar 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 ((vcalendar datetime) #:select (parse-datetime))
#:duplicates (last) ; Replace @var{count}
#:use-module (vcalendar recurrence internal)
#:use-module (util)
#:use-module (exceptions)
#:use-module (ice-9 curried-definitions)
#:export (parse-recurrence-rule))
(define (parse-recurrence-rule str)
"Takes a RECUR value (string), and returuns a <recur-rule> object"
(catch #t
(lambda () (%build-recur-rules str))
(lambda (err cont obj key val . rest)
(let ((fmt (case err
((unfulfilled-constraint)
"ERR ~a [~a] doesn't fulfill constraint of type [~a], ignoring~%")
((invalid-value)
"ERR ~a [~a] for key [~a], ignoring.~%")
(else "~a ~a ~a"))))
(format #t fmt err val key))
(cont obj))))
(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)))
(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 () (parse-datetime val)))
(num (lambda () (string->number val)))
(nums (lambda () (string->number-list val #\,))))
(quick-case (string->symbol key) obj
(FREQ (symb) (cut memv <> intervals)) ; Requirek
(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)))
;; TODO
;; <weekday> ∈ weekdays
;; <weekdaynum> ::= [[±] <num>] <weekday> ;; +3MO
;; (<weekadynum>, ...)
;; (BYDAY (string-split val #\,))
(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 #\;))))
|
