summaryrefslogtreecommitdiff
path: root/ebus-racket/3rdparty/bzlib/base/registry.ss
diff options
context:
space:
mode:
Diffstat (limited to 'ebus-racket/3rdparty/bzlib/base/registry.ss')
-rw-r--r--ebus-racket/3rdparty/bzlib/base/registry.ss215
1 files changed, 215 insertions, 0 deletions
diff --git a/ebus-racket/3rdparty/bzlib/base/registry.ss b/ebus-racket/3rdparty/bzlib/base/registry.ss
new file mode 100644
index 0000000..d0b0c72
--- /dev/null
+++ b/ebus-racket/3rdparty/bzlib/base/registry.ss
@@ -0,0 +1,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?))
+ )
+