#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
(require mzlib/pconvert-prop
         scheme/port
         scheme/string
         "base.ss"
         )
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; registry
;; a abstraction over key/value pairs

(define-struct registry (get set del (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)

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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)
  (make-registry hash-ref set del (cond ((list? hash)
                                         (let ((h (make-hash)))
                                           (for-each (lambda (kv)
                                                       (hash-set! h (car kv) (cdr kv)))
                                                     hash)
                                           h))
                                        (else hash))))

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; make-immutable-hash-registry
(define (make-immutable-hash-registry (hash (make-immutable-hash '())))
  (make-registry hash-ref hash-set hash-remove
                 (cond ((list? hash) (make-immutable-hash hash))
                       ((and (immutable? hash) (hash? hash)) hash)
                       (else (error 'make-immutable-hash-registry
                                    "Unknown hash ~a" 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-assoc-registry (lst '()))
  (make-registry assoc-ref assoc-set assoc-del 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 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))
                   (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))
 (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?))
 )