wtf

database.scm

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