blob: 3e75e566d5bd6411333ea1b2b1b621abe9630b78 (
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
|
(define-module (vcomponent base)
:use-module (util)
:use-module (srfi srfi-1)
:use-module (srfi srfi-9)
:use-module (srfi srfi-9 gnu)
:use-module (srfi srfi-17)
:use-module (ice-9 hash-table)
:use-module ((ice-9 optargs) :select (define*-public))
)
;;; <vcomponent>
;;; <properties>
;;; <dtstart>
;;; <parameters>
;;; <tzid><text>Europe/Stockholm</text></tzid>
;;; </parameters>
;;; 2020-01-01T13:37:50
;;; </dtstart>
;;; </properties>
;;; </vcomponent>
;;;
(define-record-type <vline>
(make-vline% key value parameters)
vline?
(key vline-key)
(value get-vline-value set-vline-value!)
(parameters get-vline-parameters)
(source get-source set-source!)
)
(export vline-key)
(set-record-type-printer!
<vline>
(lambda (v p)
(format p "#<<vline> key: ~s value: ~s parameters: ~s>"
(vline-key v)
(get-vline-value v)
(hash-map->list list (get-vline-parameters v)))))
(define-public vline-source
(make-procedure-with-setter
get-source set-source!))
(define*-public (make-vline key value #:optional (ht (make-hash-table)))
(make-vline% key value ht))
(define-record-type <vcomponent>
(make-vcomponent% type children parent properties)
vcomponent?
(type type)
(children children set-component-children!)
(parent get-component-parent set-component-parent!)
(properties get-component-properties))
(export vcomponent? children type)
((@ (srfi srfi-9 gnu) set-record-type-printer!)
<vcomponent>
(lambda (c p)
(format p "#<<vcomponent> ~a, len(child)=~a, parent=~a>~%"
(type c)
(length (children c))
(and=> (get-component-parent c) type))))
;; TODO should this also update the parent
(define-public parent
(make-procedure-with-setter
get-component-parent set-component-parent!))
(define*-public (make-vcomponent #:optional (type 'VIRTUAL))
(make-vcomponent% type '() #f (make-hash-table)))
(define-public (add-child! parent child)
(set-component-children! parent (cons child (children parent)))
(set-component-parent! child parent))
;;; TODO key=DTSTART, (date? value) => #t
;;; KRÄVER att (props vline 'VALUE) <- "DATE"
(define (set-property! component key value)
(let ((ht (get-component-properties component)))
(cond [(hashq-ref ht key #f)
=> (lambda (vline) (set-vline-value! vline value))]
[else (hashq-set! ht key (make-vline key value))])))
(define-public (set-vline! component key vline)
(hashq-set! (get-component-properties component)
key vline))
;; vline → value
(define-public value
(make-procedure-with-setter
get-vline-value set-vline-value!))
;; vcomponent x (or str symb) → vline
(define (get-prop* component prop)
(hashq-ref (get-component-properties component)
(as-symb prop)))
(define (set-prop*! component key value)
(hashq-set! (get-component-properties component)
(as-symb key) value))
(define-public prop*
(make-procedure-with-setter
get-prop*
set-prop*!))
;; vcomponent x (or str symb) → value
(define (get-prop component key)
(let ((props (get-prop* component key)))
(cond [(not props) #f]
[(list? props) (map value props)]
[else (value props)])))
;; TODO do something sensible here
(define (set-prop! component key value)
(set-property! component (as-symb key) value))
(define-public prop
(make-procedure-with-setter
get-prop
set-prop!))
(define-public param
(make-procedure-with-setter
(lambda (vline parameter-key)
;; TODO `list' is a hack since a bit to much code depends
;; on prop always returning a list of values.
(and=> (hashq-ref (get-vline-parameters vline)
(as-symb parameter-key))
list))
(lambda (vline parameter-key val)
(hashq-set! (get-vline-parameters vline)
(as-symb parameter-key) val))))
;; Returns the parameters of a property as an assoc list.
;; @code{(map car <>)} leads to available parameters.
(define-public (parameters vline)
(hash-map->list list (get-vline-parameters vline)))
(define-public (properties component)
(hash-map->list cons (get-component-properties component)))
(define-public (property-keys component)
(map car (get-component-properties component)))
(define (copy-vline vline)
(make-vline (vline-key vline)
(get-vline-value vline)
;; TODO deep-copy on parameters?
(get-vline-parameters vline)))
(define-public (copy-vcomponent component)
(make-vcomponent%
(type component)
(children component)
(parent component)
;; properties
(alist->hashq-table
(hash-map->list (lambda (key value)
(cons key (if (list? value)
(map copy-vline value)
(copy-vline value))))
(get-component-properties component)))))
(define-public (extract field)
(lambda (e) (prop e field)))
(define-public (extract* field)
(lambda (e) (prop* e field)))
(define-public (key=? k1 k2)
(eq? (as-symb k1)
(as-symb k2)))
(define-public (x-property? symb)
(string=? "X-" (string-take (symbol->string symb) 2)))
|
