blob: e0d7d11e886367fd6e01d933dde56050dfd42ba0 (
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
|
(define-module (vcomponent base)
:use-module (util)
:use-module (srfi srfi-1)
:use-module (srfi srfi-9)
: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% value parameters)
vline?
(value get-vline-value set-vline-value!)
(parameters get-vline-parameters)
;; TODO Add slot for optional source object, containing
;; - file of origin
;; - position in that file
;; - source string, before value parsing.
)
(define*-public (make-vline value #:optional (ht (make-hash-table)))
(make-vline% 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))
(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 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-public (attr* component attr)
(hashq-ref (get-component-attributes component)
(as-symb attr)))
;; vcomponent x (or str symb) → value
(define (get-attr component key)
(get-attribute-value component (as-symb key) #f))
(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.
(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 (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 (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)))
|
