kekkonen/database.scm

;;; 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))))