blob: 2e13f1c8847273190ec87499745c428ab8adfe82 (
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
115
116
117
118
119
120
121
122
123
124
125
126
127
128
|
(define-module (vcomponent)
:use-module (util)
:use-module (util app)
:use-module (util config)
:use-module (srfi srfi-1)
:use-module (srfi srfi-41)
:use-module (srfi srfi-41 util)
:use-module (datetime)
:use-module (vcomponent base)
:use-module (vcomponent parse)
:use-module ((vcomponent recurrence) :select (generate-recurrence-set repeating?))
:use-module ((vcomponent datetime) :select (ev-time<?))
:re-export (make-vcomponent
parse-cal-path parse-calendar))
(re-export-modules (vcomponent base))
(define-config calendar-files '()
"Which files to parse. Takes a list of paths or a single string which will be globbed."
pre: (lambda (v)
(cond [(list? v) v]
[(string? v) ((@ (glob) glob) v)]
[else #f])))
(define-public (load-calendars calendar-files)
(map parse-cal-path calendar-files))
(define-method (init-app calendar-files)
(setf 'calendars (load-calendars calendar-files))
(setf 'events
(concatenate
;; TODO does this drop events?
(map (lambda (cal) (remove
(extract 'X-HNH-REMOVED)
(filter (lambda (o) (eq? 'VEVENT (type o)))
(children cal))))
(getf 'calendars))))
(let* ((repeating regular (partition repeating? (getf 'events))))
(setf 'fixed-events (sort*! regular date/-time<? (extract 'DTSTART)))
(setf 'repeating-events (sort*! repeating date/-time<? (extract 'DTSTART))))
(setf 'event-set
(interleave-streams
ev-time<?
(cons (list->stream (getf 'fixed-events))
(map generate-recurrence-set (getf 'repeating-events)))))
(setf 'uid-map
(let ((ht (make-hash-table)))
(for-each (lambda (event) (hash-set! ht (prop event 'UID) event)) (getf 'events))
ht)))
(define-method (fixed-events-in-range start end)
(filter-sorted (lambda (ev) ((in-date-range? start end)
(as-date (prop ev 'DTSTART))))
(getf 'fixed-events)))
(define-method (get-event-by-uid uid)
(hash-ref (getf 'uid-map) uid))
;;; TODO both add- and remove-event sometimes crash with
;;;;; Warning: Unwind-only `stack-overflow' exception; skipping pre-unwind handler.
;;; I belive this is due to how getf and setf work.
;;; TODO what should happen when an event with that UID already exists
;;; in the calendar? Fail? Overwrite? Currently it adds a second element
;;; with the same UID, which is BAD.
(define-public (add-event calendar event)
(add-child! calendar event)
(unless (prop event 'UID)
(set! (prop event 'UID) (uuidgen)))
(let ((events (getf 'events)))
(setf 'events (cons event events)))
(if (repeating? event)
(let ((repeating (getf 'repeating-events)))
(setf 'repeating-events (insert-ordered event repeating ev-time<?)))
(let ((regular (getf 'fixed-events)))
(setf 'fixed-events (insert-ordered event regular ev-time<?))))
(let ((event-set (getf 'event-set)))
(setf 'event-set
(interleave-streams
ev-time<?
(list (if (repeating? event)
(generate-recurrence-set event)
(stream event))
event-set))))
(hash-set! (getf 'uid-map) (prop event 'UID)
event)
(prop event 'UID))
(define-public (remove-event event)
(let ((events (delete event (getf 'events))))
(setf 'events events))
(if (repeating? event)
(let ((repeating (delete event (getf 'repeating-events))))
(setf 'repeating-events repeating))
(let ((regular (delete event (getf 'fixed-events))))
(setf 'fixed-events regular)))
(let ((event-set
(stream-remove
(lambda (ev)
(equal? (prop ev 'UID)
(prop event 'UID)))
(getf 'event-set))))
(setf 'event-set event-set))
(hash-set! (getf 'uid-map) (prop event 'UID)
#f))
|
