blob: d0b0c72b5fe0aeb7512820755a99c71f6e3d1b8c (
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
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
|
#lang scheme/base
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; BASE.plt - common routines that are shared by all other bzlib modules
;;
;; in a way, base.plt is the most fundamental module of the whole bzlib stack
;; and as such it also is the lowest level code. We are not likely to
;; fix the code any time soon, and hence any of the functions here are
;; explicitly likely to be obsoleted or moved elsewhere.
;;
;; Proceed with caution.
;;
;;
;; Bonzai Lab, LLC. All rights reserved.
;;
;; Licensed under LGPL.
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; registry.ss - generalized key/value access (including an extensible condition object)
;; yc 9/8/2009 - first version
;; yc 7/7/2010 - add registry-clear! & modified registry definition.
(require mzlib/pconvert-prop
scheme/port
scheme/string
scheme/contract
"base.ss"
)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; registry
;; a abstraction over key/value pairs
(define-struct registry (get set del make (table #:mutable)))
(define (registry-set! reg key val)
(set-registry-table! reg
((registry-set reg) (registry-table reg) key val)))
(define (registry-del! reg key)
(set-registry-table! reg
((registry-del reg) (registry-table reg) key)))
(define (registry-ref reg key (default #f))
((registry-get reg) (registry-table reg) key default))
;; (trace registry-ref)
(define (registry-clear! reg) ;; clearing the registry... we need to fill it with a default value, of course.
;; that means we need a way to get the default value... does that mean we will have to empty out the whole value...
;; is there a way to do so without adding a new field?
;; it is completely unclear... hmm...
;; a hash's function is make-hash...
;; an immutable-hash's function is make-immutable-hash-helper...
;; an assoc's function
(set-registry-table! reg ((registry-make reg))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; make-hash-registry
(define (make-hash-registry (hash (make-hash)))
(define (set hash key val)
(hash-set! hash key val)
hash)
(define (del hash key)
(hash-remove! hash key)
hash)
(define (make (value (make-hash)))
(cond ((hash? value) value)
((list? value)
(let ((h (make-hash)))
(for-each (lambda (kv)
(hash-set! h (car kv) (cdr kv)))
value)
h))
(else (error 'make-hash-unknown-input "~a" value))))
(make-registry hash-ref set del make (make hash)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; make-immutable-hash-registry
(define (make-immutable-hash-registry (hash (make-immutable-hash '())))
(define (make (value (make-immutable-hash '())))
(cond ((and (immutable? value) (hash? value)) value)
((hash? value) (make-immutable-hash (hash-map value cons)))
((list? value) (make-immutable-hash value))
(else (error 'make-immutable-hash-unknown-input "~a" value))))
(make-registry hash-ref hash-set hash-remove make (make hash)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; make-assoc-registry (not thread safe if multiple addition & deletion)
;; let's also a list registry via assoc.
(define (assoc-ref lst key (default #f))
(define (assoc/cdr key value (default #f))
(let ((value (assoc key value)))
(if (not value) default
(cdr value))))
(assoc/cdr key lst default))
;; (trace assoc-ref)
;; if we just want to remove the first guy with the key... how to do that? not with filter.
(define (assoc-del lst key)
(define (helper k kv)
(equal? k (car kv)))
;; (trace helper)
(remove key lst helper))
(define (assoc-set lst key val)
(let ((exists? #f))
(let ((lst (map (lambda (kv)
(cons (car kv)
(cond ((equal? (car kv) key)
(set! exists? #t)
val)
(else (cdr kv)))))
lst)))
(if exists? lst
(cons (cons key val) lst)))))
(define (make-list (lst '()))
(if (list? lst)
lst
(error 'make-assoc-list-unknown-input "~a" lst)))
(define (make-assoc-registry (lst '()))
(make-registry assoc-ref assoc-set assoc-del make-list (make-list lst)))
;; what can be passed into ? it must be a list of lists.
(define (list->assoc-registry lst)
(define (helper kvs)
(cons (car kvs)
(make-assoc-registry (cdr kvs))))
;; (trace helper)
(make-assoc-registry (map helper lst)))
(define (assoc-registry->list reg)
(map (lambda (kv)
(cons (car kv)
(registry-table (cdr kv))))
(registry-table reg)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; cond-registry (takes in a cond & result pair).
(define (cond-ref lst key (default #f))
(let ((it (assf (lambda (cond)
(cond key)) lst)))
(if (not it) default
(cdr it))))
(define (make-cond-registry (lst '()))
(make-registry cond-ref assoc-set assoc-del make-list (make-list lst)))
(provide/contract
(struct registry ((get (->* (any/c any/c)
(any/c)
any))
(set (-> any/c any/c any/c any))
(del (-> any/c any/c any))
(make (->* ()
(any/c)
any/c))
(table any/c)))
(registry-ref (->* (registry? any/c)
(any/c)
any))
(registry-set! (-> registry? any/c any/c any))
(registry-del! (-> registry? any/c any))
(registry-clear! (-> registry? any))
(make-hash-registry (->* ()
((or/c list? hash?))
registry?))
(make-immutable-hash-registry (->* ()
((or/c list? (and/c immutable? hash?)))
registry?))
(assoc-ref (->* (list? any/c)
(any/c)
any))
(assoc-set (-> list? any/c any/c any))
(assoc-del (-> list? any/c any))
(make-assoc-registry (->* ()
(list?)
registry?))
(list->assoc-registry (-> list? registry?))
(assoc-registry->list (-> registry? list?))
(make-cond-registry (->* ()
(list?)
registry?))
)
;; let's see how something can be flushed...
(define (registry->out reg out)
(write (registry-table reg) out))
(define (registry->string reg)
(let ((out (open-output-bytes)))
(registry->out reg out)
(get-output-string out)))
(define (in->registry in)
(let ((value (read in)))
(cond ((list? value)
(make-assoc-registry value))
((and (hash? value) (immutable? value))
(make-immutable-hash-registry value))
((hash? value)
(make-hash-registry value))
((eof-object? value)
(make-assoc-registry))
(else
(error 'in->registry "unknown registry type ~a" value)))))
(define (string->registry string)
(in->registry (open-input-string string)))
(provide/contract
(registry->out (-> registry? output-port? any))
(registry->string (-> registry? string?))
(in->registry (-> input-port? registry?))
(string->registry (-> string? registry?))
)
|