blob: 2748e8beebfffdfac570a1bfef3b2a3a889b0e4f (
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
|
(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))
)
;; The <vline> type is a bit to many times refered to as a attr ptr.
(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 attributes)
vcomponent?
(type type)
(children children set-component-children!)
(parent get-component-parent set-component-parent!)
(attributes get-component-attributes))
(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 this doesn't handle multi-valued items
(define* (get-attribute-value component key #:optional default)
(cond [(hashq-ref (get-component-attributes component)
key #f)
=> get-vline-value]
[else default]))
(define (get-attribute component key)
(hashq-ref (get-component-attributes component)
key))
(define (set-attribute! component key value)
(let ((ht (get-component-attributes 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-attributes 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-attr* component attr)
(hashq-ref (get-component-attributes component)
(as-symb attr)))
(define (set-attr*! component key value)
(hashq-set! (get-component-attributes component)
(as-symb key) value))
(define-public attr*
(make-procedure-with-setter
get-attr*
set-attr*!))
;; vcomponent x (or str symb) → value
(define (get-attr component key)
(let ((attrs (get-attr* component key)))
(cond [(not attrs) #f]
[(list? attrs) (map value attrs)]
[else (value attrs)])))
;; TODO do something sensible here
(define (set-attr! component key value)
(set-attribute! component (as-symb key) value))
(define-public attr
(make-procedure-with-setter
get-attr
set-attr!))
(define-public prop
(make-procedure-with-setter
(lambda (attr-obj prop-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 attr-obj)
(as-symb prop-key))
list))
(lambda (attr-obj prop-key val)
(hashq-set! (get-vline-parameters attr-obj)
(as-symb prop-key) val))))
;; Returns the properties of attribute as an assoc list.
;; @code{(map car <>)} leads to available properties.
;; TODO shouldn't this be called parameters?
(define-public (properties attrptr)
(hash-map->list list (get-vline-parameters attrptr)))
(define-public (attributes component)
(get-component-attributes component))
(define-public (attribute-keys component)
(map car (hash-map->list cons (get-component-attributes component))))
(define (copy-vline vline)
(make-vline (vline-key vline)
(get-vline-value vline)
;; TODO deep-copy on properties?
(get-vline-parameters vline)))
(define-public (copy-vcomponent component)
(make-vcomponent%
(type component)
(children component)
(parent component)
;; attributes
(alist->hashq-table
(hash-map->list (lambda (key value)
(cons key (if (list? value)
(map copy-vline value)
(copy-vline value))))
(get-component-attributes component)))))
(define-public (extract field)
(lambda (e) (attr e field)))
(define-public (extract* field)
(lambda (e) (attr* e field)))
(define-public (key=? k1 k2)
(eq? (as-symb k1)
(as-symb k2)))
|
