blob: de21281c03ab788819b2a17c719495ea18830be5 (
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
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
|
;;; Commentary:
;; Tests that event-clamping (checking how long part of an event
;; overlaps another time span) works.
;;; Code:
(define-module (test vcomponent-datetime)
:use-module (srfi srfi-1)
:use-module (srfi srfi-41)
:use-module (srfi srfi-64)
:use-module (srfi srfi-88)
:use-module (datetime)
:use-module ((hnh util) :select (->> sort*))
:use-module (hnh util lens)
:use-module ((datetime zic) :select (read-zoneinfo))
:use-module (datetime timespec)
:use-module ((vcomponent) :select (vcomponent-equal? extract prop))
:use-module (vcomponent datetime)
:use-module ((vcomponent recurrence) :select (recur-rule))
:use-module ((vcomponent create) :select (vevent vtimezone daylight standard)))
(test-group "overlapping?"
(test-assert "date, datetime"
(overlapping?
(vevent summary: "A"
dtstart: (date year: 2020 month: jan day: 1)
dtend: (date year: 2022 month: dec day: 31))
(vevent summary: "B"
dtstart: (datetime year: 2020 month: apr day: 1 hour: 10)
dtend: (datetime year: 2020 month: apr day: 1 hour: 12))))
(test-assert "date, date"
(overlapping?
(vevent summary: "A"
dtstart: (date year: 2020 month: jan day: 1)
dtend: (date year: 2020 month: jan day: 20))
(vevent summary: "B"
dtstart: (date year: 2020 month: jan day: 10)
dtend: (date year: 2020 month: feb day: 10))))
(test-assert "datetime, date"
(not
(overlapping?
(vevent summary: "A"
dtstart: (datetime year: 2020 month: apr day: 1 hour: 10)
dtend: (datetime year: 2020 month: apr day: 1 hour: 12))
(vevent summary: "B"
dtstart: (date year: 2020 month: jan day: 10)
dtend: (date year: 2020 month: feb day: 10)))))
(test-assert "datetime, datetime"
(overlapping?
(vevent summary: "A"
dtstart: (datetime year: 2020 month: apr day: 1 hour: 10)
dtend: (datetime year: 2020 month: apr day: 1 hour: 12))
(vevent summary: "B"
dtstart: (datetime year: 2020 month: apr day: 1 hour: 11)
dtend: (datetime year: 2020 month: apr day: 1 hour: 13))))
(test-assert "Without dtend"
(overlapping?
(vevent summary: "A"
dtstart: (date year: 2020 month: apr day: 1))
(vevent summary: "B"
dtstart: (datetime year: 2020 month: apr day: 1 hour: 10)))))
(test-group "event-contains?"
(let* ((dt (datetime year: 2020 month: jan day: 1
hour: 10))
(ev (vevent dtstart: dt
dtend: (datetime+ dt (datetime hour: 5)))))
(test-assert (event-contains? ev dt))
(test-assert (not (event-contains? ev (set dt datetime-date day 10))))))
(test-group "event-zero-length?"
(test-assert (not (event-zero-length? (vevent dtstart: (date)))))
(test-assert (event-zero-length? (vevent dtstart: (datetime))))
(test-assert (not (event-zero-length? (vevent dtstart: (datetime)
dtend: (datetime))))))
(test-assert "ev-time<?"
(ev-time<?
(vevent summary: "A"
dtstart: (datetime year: 2020 month: apr day: 1 hour: 10))
(vevent summary: "B"
dtstart: (datetime year: 2020 month: apr day: 1 hour: 11))))
(test-group "event-length"
(test-equal "Datetime, with DTEND"
(datetime day: 2 hour: 17)
(event-length
(vevent
dtstart: (datetime year: 2020 month: 3 day: 29 hour: 17)
dtend: (datetime year: 2020 month: 4 day: 1 hour: 10))))
(test-equal "Datetime, without DTEND"
(datetime)
(event-length
(vevent
dtstart: (datetime year: 2020 month: 3 day: 29 hour: 17))))
(test-equal "Date, with DTEND"
(date day: 3)
(event-length
(vevent
dtstart: (date year: 2020 month: 3 day: 29)
dtend: (date year: 2020 month: 4 day: 1))))
(test-equal "Date, without DTEND"
(date day: 1)
(event-length
(vevent
dtstart: (date year: 2020 month: 3 day: 29)))))
(test-group "event-length/clamped"
(let ((ev
(vevent
dtstart: (datetime year: 2020 month: 3 day: 29 hour: 17)
dtend: (datetime year: 2020 month: 4 day: 1 hour: 10))))
;; |-----------------| test interval
;; |----------| event interval
(test-equal "Correct clamping"
(datetime hour: 7) ; 2020-03-29T17:00 - 2020-03-30T00:00
(event-length/clamped
(date year: 2020 month: 3 day: 23) ; a time way before the start of the event
(date year: 2020 month: 3 day: 29) ; a time slightly after the end of the event
ev))
;; TODO why is this object created?
(define utc-ev
(vevent
dtstart: (datetime year: 2020 month: 3 day: 29 hour: 15 tz: "UTC")
dtend: (datetime year: 2020 month: 4 day: 1 hour: 8 tz: "UTC")))
(test-equal "Correct clamping UTC"
(datetime hour: 7)
(event-length/clamped
(date year: 2020 month: 3 day: 23)
(date year: 2020 month: 3 day: 29)
ev)))
(let ((ev (vevent dtstart: (datetime year: 2020 month: 3 day: 1))))
(test-equal
(datetime)
(event-length/clamped
(date year: 2020 month: 3 day: 1)
(date year: 2020 month: 3 day: 2)
ev
))
)
;; TODO test with no dtend (datetime)
;; TODO test with no dtend (date)
;; TODO test where both dtstart and dtend are date's
)
(let ((d (date year: 2020 month: jan day: 10)))
(test-group "event-length/day"
;; TODO shouldn't a check for the correct date be done?
(test-equal
(time hour: 24)
(event-length/day
d
(vevent dtstart: (date))))
(test-equal
(time)
(event-length/day
d
(vevent dtstart: (datetime))))
(test-equal "Within day"
(time hour: 10)
(event-length/day
d
(vevent dtstart: (datetime date: d hour: 10)
dtend: (datetime date: d hour: 20))))
(test-equal "Ends tommorrow"
(time hour: 14)
(event-length/day
d
(vevent dtstart: (datetime date: d hour: 10)
dtend: (datetime date: (date+ d (date day: 1)) hour: 20))))
(test-equal "Started yesterday"
(time hour: 10)
(event-length/day
d
(vevent dtstart: (datetime date: (date- d (date day: 1)) hour: 10)
dtend: (datetime date: d hour: 10))))
(test-equal "Starts before date, ends after date"
(time hour: 24)
(event-length/day
d
(vevent dtstart: (datetime date: (date- d (date day: 1)) hour: 10)
dtend: (datetime date: (date+ d (date day: 1)) hour: 10))))
;; TODO Test invalid cases
))
(test-group "long-event?"
(test-assert "DTSTART being date is always a long event"
(long-event? (vevent dtstart: (date))))
(test-assert "datetime DTSTART without DTEND is always short"
(not (long-event? (vevent dtstart: (datetime)))))
(test-assert "Event longer than 24h"
(not
(long-event? (vevent dtstart: (datetime year: 2020 month: 1 day: 1 hour: 10)
dtend: (datetime year: 2020 month: 1 day: 1 hour: 20)))))
(test-assert "Event shorter than 24h"
(long-event? (vevent dtstart: (datetime year: 2020 month: 1 day: 1
hour: 1)
dtend: (datetime year: 2020 month: 1 day: 2
hour: 1 minute: 1)))))
(test-group "really-long-event?"
(test-assert (not (really-long-event?
(vevent dtstart: (date year: 2020 month: jan day: 1)
dtend: (date year: 2020 month: jan day: 2)))))
(test-assert (really-long-event?
(vevent dtstart: (date year: 2020 month: jan day: 1)
dtend: (date year: 2020 month: jan day: 3))))
(test-assert (not (really-long-event?
(vevent dtstart: (datetime year: 2020 month: jan day: 1)
dtend: (datetime year: 2020 month: jan day: 2)))))
(test-assert (really-long-event?
(vevent dtstart: (datetime year: 2020 month: jan day: 1)
dtend: (datetime year: 2020 month: jan day: 2 second: 1))))
)
(test-group "events-between"
(let ((start (date year: 2020 month: jan day: 1))
(end (date year: 2022 month: jan day: 1)))
(let ((expected
(list (vevent dtstart: (date year: 2020 month: jan day: 1))
(vevent dtstart: (date year: 2021 month: dec day: 31))
(vevent dtstart: (date year: 2022 month: jan day: 1))))
(actual
(->> (sort*
(list (vevent dtstart: (date year: 2019 month: jan))
(vevent dtstart: (date year: 2019 month: dec day: 31))
(vevent dtstart: (date year: 2020 month: jan day: 1))
(vevent dtstart: (date year: 2021 month: dec day: 31))
(vevent dtstart: (date year: 2022 month: jan day: 1)))
date< (extract 'DTSTART))
list->stream
(events-between start end)
stream->list
)))
(test-equal (length expected) (length actual))
(for-each
(lambda (name a b)
(test-equal name
(prop a 'DTSTART)
(prop b 'DTSTART)
))
(map number->string (iota 10))
expected
actual)))
)
(test-group "zoneinfo->vtimezone"
(let* ((zoneinfo-sample
"
# Rule NAME FROM TO - IN ON AT SAVE LETTER/S
Rule Swiss 1941 1942 - May Mon>=1 1:00 1:00 S
Rule Swiss 1941 1942 - Oct Mon>=1 2:00 0 -
Rule EU 1977 1980 - Apr Sun>=1 1:00u 1:00 S
Rule EU 1977 only - Sep lastSun 1:00u 0 -
Rule EU 1978 only - Oct 1 1:00u 0 -
Rule EU 1979 1995 - Sep lastSun 1:00u 0 -
Rule EU 1981 max - Mar lastSun 1:00u 1:00 S
Rule EU 1996 max - Oct lastSun 1:00u 0 -
# Zone NAME STDOFF RULES FORMAT [UNTIL]
Zone Europe/Zurich 0:34:08 - LMT 1853 Jul 16
0:29:45.50 - BMT 1894 Jun
1:00 Swiss CE%sT 1981
1:00 EU CE%sT
Link Europe/Zurich Europe/Vaduz
")
(zoneinfo
(call-with-input-string
zoneinfo-sample
(compose read-zoneinfo list)))
(timezone-component
;; Seed random to stable UID's.
(parameterize (((@ (hnh util uuid) seed) (seed->random-state 0)))
(zoneinfo->vtimezone
zoneinfo
"Europe/Zurich"
(vevent summary: "Zoneinfo test"
dtstart: (datetime year: 2020 month: jan day: 10 hour: 10))))))
(test-assert
(vcomponent-equal?
(vtimezone tzid: "Europe/Zurich"
(list
(daylight
dtstart: (datetime year: 1981 month: 3 day: 29 hour: 1 tz: "UTC")
rrule: (recur-rule freq: 'YEARLY interval: 1 byday: `((-1 . ,sun)) bymonth: '(3) wkst: monday)
tzname: "CEST"
;; TODO why isn't this 'hour: 1'?
tzoffsetfrom: (make-timespec (time hour: 0) '+ #\w)
tzoffsetto: (make-timespec (time hour: 2) '+ #\w)
uid: "d19c9347-9a85-4432-a876-5fb9c0d24d2b")
(standard
dtstart: (datetime year: 1996 month: 10 day: 27 hour: 1 tz: "UTC")
rrule: (recur-rule freq: 'YEARLY interval: 1 byday: `((-1 . ,sun)) bymonth: '(10) wkst: monday)
tzname: "CET"
tzoffsetfrom: (make-timespec (time hour: 2) '+ #\w)
tzoffsetto: (make-timespec (time hour: 1) '+ #\w)
uid: "7dce30d4-6aaa-4cfb-85dc-813f74d7f4a9")))
timezone-component)))
;; TODO these tests
;; (let* () "min max")
;; (let () "min - time")
;; (let "only")
)
'((vcomponent datetime))
|
