blob: 355839f05b47d6ade1f6b7c2ff4557af1b2a1408 (
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
|
(define-module (vcomponent create)
:use-module ((vcomponent base) :prefix vcs-)
:use-module ((vcomponent base)
:select (vline key add-child prop* vline?))
:use-module ((srfi srfi-1) :select (fold last drop-right car+cdr))
:use-module (srfi srfi-17)
:use-module (srfi srfi-71)
:use-module (srfi srfi-88)
:use-module ((hnh util table) :select (alist->table))
:use-module ((hnh util) :select (swap init+last kvlist->assq ->))
:use-module (hnh util object)
:export (with-parameters
as-list
vcomponent
vcalendar vevent
vtimezone standard daylight
))
;; TODO allow parameters and list values at same time
;; Convert a scheme keyword to a symbol suitable for us
(define (keyword->key keyword)
(-> keyword
keyword->string
string-upcase ; NOCOV
string->symbol))
(define (symbol-upcase symbol)
(-> symbol
symbol->string
string-upcase ; NOCOV
string->symbol))
;; Upcase the keys in an association list. Keys must be symbols.
(define (upcase-keys alist)
(map (lambda (pair) (cons (symbol-upcase (car pair))
(cdr pair)))
alist))
(define (with-parameters . args)
(define-values (parameters value)
(init+last args))
(vline
key: 'PLACEHOLDER
vline-value: value
vline-parameters:
(-> parameters
kvlist->assq
upcase-keys
alist->table)))
(define-type (list-value)
(list-value-value))
(define (as-list arg)
(list-value list-value-value: arg))
(define (vcomponent type . attrs*)
(define-values (attrs children)
(cond ((null? attrs*) (values '() '()))
((even? (length attrs*)) (values attrs* '()))
(else (init+last attrs*))))
;; TODO add-child requires a UID on the child
;; Possibly just genenerate one here if missing
(fold (swap add-child)
(fold (lambda (pair component)
(let ((k value (car+cdr pair)))
(prop* component k
(cond ((vline? value)
(key value k))
((list-value? value)
(map (lambda (value) (vline key: k vline-value: value))
(list-value-value value)))
(else (vline key: k vline-value: value))))))
(vcs-vcomponent
type: type)
(upcase-keys (kvlist->assq attrs)))
children))
(define (vcalendar . attrs)
(apply vcomponent 'VCALENDAR attrs))
(define (vevent . attrs)
(apply vcomponent 'VEVENT attrs))
(define (vtimezone . attrs)
(apply vcomponent 'VTIMEZONE attrs))
(define (standard . attrs)
(apply vcomponent 'STANDARD attrs))
(define (daylight . attrs)
(apply vcomponent 'DAYLIGHT attrs))
|
