91 lines
2.9 KiB
Scheme
91 lines
2.9 KiB
Scheme
|
;;; Database module, serializing kv stores associated with symbols
|
||
|
|
;;; to and from s-expressions on file.
|
||
|
|
|
||
|
|
(module database (database-set database-get database-save *database* database-load database-remove get-all-objects object-exists? has-property? toggle-flag database-null)
|
||
|
|
(import scheme)
|
||
|
|
(import chicken.io)
|
||
|
|
(import util)
|
||
|
|
|
||
|
|
;; The global database.
|
||
|
|
(define *database* '())
|
||
|
|
|
||
|
|
;; This has to exist and be exported in order for the test suite
|
||
|
|
;; not to trigger warnings.
|
||
|
|
(define (database-null)
|
||
|
|
(set! *database* '()))
|
||
|
|
|
||
|
|
;; Set KEY associated with symbol NAME to VALUE.
|
||
|
|
(define (database-set name key value)
|
||
|
|
(set! *database* (let loop ((kv *database*))
|
||
|
|
(if (null? kv)
|
||
|
|
(list (cons name (list (cons key value))))
|
||
|
|
(if (equal? name (caar kv))
|
||
|
|
(cons (cons name (let loop ((kv (cdar kv)))
|
||
|
|
(if (null? kv)
|
||
|
|
(list (cons key value))
|
||
|
|
(if (equal? key (caar kv))
|
||
|
|
(cons (cons key value) (cdr kv))
|
||
|
|
(cons (car kv) (loop (cdr kv))))))) (cdr kv))
|
||
|
|
(cons (car kv) (loop (cdr kv))))))))
|
||
|
|
|
||
|
|
;; Get KEY associated with symbol NAME, returning DEFAULT if it doesn't exist.
|
||
|
|
(define (database-get name key default)
|
||
|
|
(let loop ((kv *database*))
|
||
|
|
(if (null? kv)
|
||
|
|
default
|
||
|
|
(if (equal? name (caar kv))
|
||
|
|
(let loop ((kv (cdar kv)))
|
||
|
|
(if (null? kv)
|
||
|
|
default
|
||
|
|
(if (equal? key (caar kv))
|
||
|
|
(cdar kv)
|
||
|
|
(loop (cdr kv)))))
|
||
|
|
(loop (cdr kv))))))
|
||
|
|
|
||
|
|
;; Save database to a file, in s-expression format.
|
||
|
|
(define (database-save filename)
|
||
|
|
(with-output-to-file filename (thunk (write *database*))))
|
||
|
|
|
||
|
|
;; Load database from a file.
|
||
|
|
(define (database-load filename)
|
||
|
|
(with-input-from-file filename (thunk (set! *database* (car (read-list))))))
|
||
|
|
|
||
|
|
;; Remove all associations from symbol NAME from database.
|
||
|
|
(define (database-remove name)
|
||
|
|
(set! *database* (let loop ((kv *database*))
|
||
|
|
(if (null? kv)
|
||
|
|
'()
|
||
|
|
(if (equal? name (caar kv))
|
||
|
|
(cdr kv)
|
||
|
|
(cons (car kv) (loop (cdr kv))))))))
|
||
|
|
|
||
|
|
;; Get a list of all symbols in the database.
|
||
|
|
(define (get-all-objects)
|
||
|
|
(map car *database*))
|
||
|
|
|
||
|
|
;; Does a symbol exist in the database, e.g. is there
|
||
|
|
;; a symbol that has values associated with it in the database?
|
||
|
|
(define (object-exists? object)
|
||
|
|
(list? (member object (get-all-objects))))
|
||
|
|
|
||
|
|
;; Is there a value PROPERTY associated with the symbol OBJECT?
|
||
|
|
(define (has-property? object property)
|
||
|
|
(let loop ((kv *database*))
|
||
|
|
(if (null? kv)
|
||
|
|
#f
|
||
|
|
(if (eq? (caar kv) object)
|
||
|
|
(let loop ((kv (cdar kv)))
|
||
|
|
(if (null? kv)
|
||
|
|
#f
|
||
|
|
(if (eq? (caar kv) property)
|
||
|
|
#t
|
||
|
|
(loop (cdr kv)))))
|
||
|
|
(loop (cdr kv))))))
|
||
|
|
|
||
|
|
;; If OBJECT has a value FLAG that is unset or false, set it to true.
|
||
|
|
;; Else set it to false.
|
||
|
|
(define (toggle-flag object flag)
|
||
|
|
(if (database-get object flag #f)
|
||
|
|
(database-set object flag #f)
|
||
|
|
(database-set object flag #t))))
|