blob: 169a28836fcec6561ac1421b50f5d5a20e584fab (
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
|
(define-module (vcalendar recur)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-26)
#:use-module (vcalendar datetime)
#:use-module (util)
#:export (<recur-rule> build-recur-rules))
(define-immutable-record-type <recur-rule>
(make-recur-rules
freq until count interval bysecond byminute byhour wkst)
recur-rule?
(freq get-freq set-freq)
(until get-until set-until)
(count get-count set-count)
(interval get-interval set-interval) ; 1
(bysecond get-bysecond set-bysecond)
(byminute get-byminute set-byminute)
(byhour get-byhour set-byhour)
(wkst get-wkst set-wkst) ; MO
)
;; (build-recur-rules "FREQ=HOURLY") ; => #<<recur-rule> freq: HOURLY until: #f count: #f interval: #f>
;; (build-recur-rules "FREQ=HOURLY;COUNT=3") ; => #<<recur-rule> freq: HOURLY until: #f count: 3 interval: #f>
;; (build-recur-rules "FREQ=ERR;COUNT=3") ; => #<<recur-rule> freq: #f until: #f count: 3 interval: #f>
;; (build-recur-rules "FREQ=HOURLY;COUNT=err") ; => #<<recur-rule> freq: HOURLY until: #f count: #f interval: #f>
;; (build-recur-rules "FREQ=HOURLY;COUNT=-1") ; => #<<recur-rule> freq: HOURLY until: #f count: #f interval: #f>
(define (build-recur-rules str)
(catch-let
(lambda () (%build-recur-rules str))
((unknown-key
(lambda (err cont obj key . rest)
(format #t "ERR Invalid key [~a] while parsing recurence rule, ignoring.~%" key)
(cont obj)))
(unfulfilled-constraint
(lambda (err cont obj key val . rest)
(let ((default-value (case key
((INTERVAL) 1)
(else #f))))
(format #t "ERR Value [~a] doesn't fulfill constraint of type [~a], defauting to [~a].~%"
val key default-value)
(cont default-value))))
(invalid-value
(lambda (err cont obj key val . rest)
(format #t "ERR Invalid value [~a] for key [~a], ignoring.~%" val key)
(cont obj))))))
(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 weekdays
'(SU MO TU WE TH FR SA))
;;; A special form of case only useful in build-recur-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 (x)
(let ((syntax-helper
(lambda (obj parent-expr expr)
"Helper function for quick-case below"
(with-syntax ((obj (datum->syntax parent-expr obj)))
(syntax-case expr ()
((key val proc)
(let ((make-setter (lambda (symb) (symbol-append 'set- (symbol-downcase symb)))))
(with-syntax ((setter (datum->syntax parent-expr (make-setter (syntax->datum (syntax key))))))
#'((key)
(cond ((not val) (call/cc (lambda (cont) (throw 'invalid-value cont obj (quote key) val))))
((proc val) (setter obj val))
(else (setter obj (call/cc (lambda (cont) (throw 'unfulfilled-constraint cont obj (quote key) val)))))))))))))))
(syntax-case x ()
((_ var-key obj (key val proc) ...)
(let ((cc (lambda (lst) (map (cut syntax-helper (syntax->datum (syntax obj)) x <>)
lst))))
#`(case var-key
#,@(cc #'((key val proc) ...))
(else (call/cc (lambda (cont) (throw 'unknown-key cont obj var-key)))))))))))
(define (%build-recur-rules str)
(fold-lists
(lambda ((key val) obj)
(quick-case (string->symbol key) obj
(FREQ (string->symbol val) (cut memv <> '(SECONDLY MINUTELY HOURLY DAILY WEEKLY MONTHLY YEARLY)))
(UNTIL (parse-datetime val) identity)
(COUNT (string->number val) (cut <= 0 <>))
(INTERVAL (string->number val) (cut <= 0 <>))
(BYSECOND (string->number-list val #\,) (cut every (cut <= 0 <> 60) <>))
(BYMINUTE (string->number-list val #\,) (cut every (cut <= 0 <> 59) <>))
(BYHOUR (string->number-list val #\,) (cut every (cut <= 0 <> 23) <>))
;; TODO implement these
;; (BYDAY)
;; (BYMONTHDAY)
;; (BYYEARDAY)
;; (BYWEEKNO)
;; (BYMONTH)
;; (BYSETPOS)
(WKST (string->symbol val) (cut memv <> weekdays))
))
((record-constructor <recur-rule> '(interval wkst)) 1 'MO)
(map (cut string-split <> #\=)
(string-split str #\;))))
|
