|
|
@@ -0,0 +1,90 @@ |
|
|
|
;;; 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)))) |