blob: 572fb020ea2e0793fe6b03616540b9f1091c7238 (
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
|
(define-module (vcalendar recur)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-26)
#:use-module (util))
(define-immutable-record-type <recur-rule>
(make-recur-rules freq until count interval)
recur-rule?
(freq get-freq set-freq)
(until get-until set-until)
(count get-count set-count)
(interval get-interval set-interval))
;; (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 (%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 (string->date 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) <>))
))
(make-recur-rules #f #f #f 1)
(map (cut string-split <> #\=)
(string-split str #\;))))
;;; 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-helper obj parent-expr expr )
"Helper function for quick-case below"
(with-syntax ((obj (datum->syntax parent-expr obj)))
(syntax-case expr ()
((key val proc)
(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))))))))))))
(define-syntax quick-case
(lambda (x)
(syntax-case x ()
((_ var-key obj (key val proc) ...)
(let* ((make-setter (lambda (symb) (symbol-append 'set- (symbol-downcase symb))))
(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))))))))))
|
