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
|
(define-module (output xcal)
:use-module (util)
:use-module (util exceptions)
:use-module (vcomponent)
:use-module (vcomponent geo)
:use-module (output sxml-types)
:use-module (ice-9 match)
:use-module (output common)
:use-module (datetime)
:use-module (datetime util)
)
(define (vline->value-tag vline)
(define key (vline-key vline))
(define writer
(cond
[(and=> (prop vline 'VALUE) string->symbol) => get-writer]
[(memv key '(COMPLETED DTEND DUE DTSTART RECURRENCE-ID
CREATED DTSTAMP LAST-MODIFIED
ACKNOWLEDGED EXDATE))
(get-writer 'DATE-TIME)]
[(memv key '(TRIGGER DURATION))
(get-writer 'DURATION)]
[(memv key '(FREEBUSY))
(get-writer 'PERIOD)]
[(memv key '(CALSCALE METHOD PRODID COMMENT DESCRIPTION
LOCATION SUMMARY TZID TZNAME
CONTACT RELATED-TO UID
CATEGORIES RESOURCES
VERSION))
(get-writer 'TEXT)]
[(memv key '(TRANSP
CLASS
PARTSTAT
STATUS
ACTION))
(lambda (p v) ((get-writer 'TEXT) p (symbol->string v)))]
[(memv key '(TZOFFSETFROM TZOFFSETTO))
(get-writer 'UTC-OFFSET)]
[(memv key '(ATTACH TZURL URL))
(get-writer 'URI)]
[(memv key '(PERCENT-COMPLETE PRIORITY REPEAT SEQUENCE))
(get-writer 'INTEGER)]
[(memv key '(GEO))
(lambda (_ v)
`(geo
(latitude ,(geo-latitude v))
(longitude ,(geo-longitude v))))]
[(memv key '(RRULE))
(get-writer 'RECUR)]
[(memv key '(ORGANIZER ATTENDEE))
(get-writer 'CAL-ADDRESS)]
[(x-property? key)
(get-writer 'TEXT)]
[else
(warning "Unknown key ~a" key)
(get-writer 'TEXT)]))
(writer ((@@ (vcomponent base) get-vline-parameters) vline) (value vline)))
(define-public (vcomponent->sxml component)
`(,(downcase-symbol (type component))
(properties
,@(hash-map->list
(match-lambda*
[(? (compose internal-field? car)) '()]
;; TODO parameters
[(key (vlines ...))
`(,(downcase-symbol key)
#;
,(unless (null? (properties vline))
`(parameters
,@(map vline->value-tag (properties vline))))
,@(for vline in vlines
(vline->value-tag vline)))]
[(key vline)
`(,(downcase-symbol key)
#;
,(unless (null? (properties vline))
`(parameters
,@(map vline->value-tag (properties vline))))
,(vline->value-tag vline))])
(attributes component)))
(components ,@(map vcomponent->sxml (children component)))))
(define-public (main calendar)
`(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
(icalendar (@ (xmlns "urn:ietf:params:xml:ns:icalendar-2.0"))
,(vcomponent->sxml calendar))))
|
