diff options
Diffstat (limited to 'ebus-racket/3rdparty/bzlib/base/registry.ss')
-rw-r--r-- | ebus-racket/3rdparty/bzlib/base/registry.ss | 215 |
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?)) + ) + |