blob: 555395cf9f004593b4b0b901a38bed6319ff5314 (
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
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
|
(define-module (vcomponent instance)
:use-module (util)
: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<?))
:use-module (oop goops)
:export (add-event remove-event
global-event-object
get-event-by-uid
fixed-events-in-range
get-event-set get-calendars
get-fixed-events get-repeating-events
))
(define-public (load-calendars calendar-files)
(map parse-cal-path calendar-files))
;;; 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.
;; == vcomponent ==
;; - calendar
;; - events
;; - repeating-events
;; - fixed-events
;; - event-set
;; - uid-map
(define-class <events> ()
(calendar-files init-keyword: calendar-files:)
(calendars getter: get-calendars)
(events getter: get-events)
(repeating-events getter: get-repeating-events)
(fixed-events getter: get-fixed-events)
(event-set getter: get-event-set)
uid-map
)
(define-method (get-event-by-uid (this <events>) uid)
(hash-ref (slot-ref this 'uid-map) uid))
(define-method (fixed-events-in-range (this <events>) start end)
(filter-sorted (lambda (ev) ((in-date-range? start end)
(as-date (prop ev 'DTSTART))))
(slot-ref this 'fixed-events)))
(define-method (initialize (this <events>) args)
(next-method)
(format (current-error-port) "Building <events> from ~a~%"
(slot-ref this 'calendar-files))
(slot-set! this 'calendars (load-calendars (slot-ref this 'calendar-files)))
(slot-set! this 'events
(concatenate
(map (lambda (cal) (remove
(extract 'X-HNH-REMOVED)
(filter (lambda (o) (eq? 'VEVENT (type o)))
(children cal))))
(slot-ref this 'calendars))))
(let* ((repeating regular (partition repeating? (slot-ref this 'events))))
(slot-set! this 'fixed-events (sort*! regular date/-time<? (extract 'DTSTART)))
(slot-set! this 'repeating-events (sort*! repeating date/-time<? (extract 'DTSTART))))
(slot-set! this 'event-set
(interleave-streams
ev-time<?
(cons (list->stream (slot-ref this 'fixed-events))
(map generate-recurrence-set (slot-ref this 'repeating-events)))))
(slot-set! this 'uid-map
(let ((ht (make-hash-table)))
(for-each (lambda (event) (hash-set! ht (prop event 'UID) event))
(slot-ref this 'events))
ht)))
;;; 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-method (add-event (this <events>) calendar event)
(add-child! calendar event)
(unless (prop event 'UID)
(set! (prop event 'UID) (uuidgen)))
(slot-set! this 'events
(cons event (slot-ref this 'events)))
(let* ((slot-name
(if (repeating? event)
'repeating-events 'fixed-events))
(events (slot-ref this slot-name)))
(slot-set! this slot-name (insert-ordered event events ev-time<?)))
(slot-set! this 'event-set
(interleave-streams
ev-time<?
(list (if (repeating? event)
(generate-recurrence-set event)
(stream event))
(slot-ref this 'event-set))))
(hash-set! (slot-ref this 'uid-map) (prop event 'UID)
event)
(prop event 'UID))
(define-method (remove-event (this <events>) event)
(slot-set! this 'events (delete event (slot-ref this 'events)))
(let ((slot-name (if (repeating? event) 'repeating-events 'fixed-events)))
(slot-set! this slot-name
(delete event (slot-ref this slot-name))))
(slot-set! this 'event-set
(stream-remove
(lambda (ev)
(equal? (prop ev 'UID)
(prop event 'UID)))
(slot-ref this 'event-set)))
(hash-set! (slot-ref this 'uid-map) (prop event 'UID)
#f))
(define-once global-event-object
(make <events> calendar-files: (get-config 'calendar-files)))
|
