Add a config file facility

lisp/local-projects/cockpit/cockpit.lisp

@@ -1,12 +1,14 @@
 (uiop:define-package :cockpit
-  (:use :cl :eql :sextant))
+  (:use :cl :eql :sextant :config))
 (in-package :cockpit)
 
 (qrequire :quick)
 
-(defun initialize ())
+(defun initialize ()
+  (load-config-file "harbour-sextant" "config.lisp"))
 
-(defun finalize ())
+(defun finalize ()
+  (save-config-file "harbour-sextant" "config.lisp"))
 
 (defun start ()
   (initialize)

lisp/local-projects/sextant/config/all.lisp

@@ -0,0 +1,4 @@
+(uiop:define-package :sextant/config/all
+  (:nicknames :config)
+  (:use-reexport
+   :sextant/config/config))

lisp/local-projects/sextant/config/config.lisp

@@ -0,0 +1,90 @@
+(uiop:define-package :sextant/config/config
+  (:use :cl)
+  (:export #:set-config-package
+           #:defconfig
+           #:load-config-file
+           #:save-config-file))
+(in-package :sextant/config/config)
+
+(defvar config-package nil)
+(defvar config-probe ";;; Auto generated from here, do not edit")
+
+(defun config-filepath (appname filename)
+  (merge-pathnames (concatenate 'string appname "/" filename)
+                   (uiop:xdg-config-pathname)))
+
+(defun set-config-package (package)
+  (setf config-package package))
+
+(defmacro defconfig (symbol default &key get set validate doc)
+  `(prog2
+       (declaim (special ,symbol))
+       (setf ,symbol ,default)
+     (export ',symbol)
+     ,(let ((getter (intern (concatenate 'string "GET-" (symbol-name symbol)))))
+       `(progn
+          ,(if get
+               `(defun ,getter ,(first get)
+                 ,@(rest get))
+               `(defun ,getter () ,symbol))
+          (export ',getter)))
+     ,(let ((setter (intern (concatenate 'string "SET-" (symbol-name symbol)))))
+       `(progn
+          ,(if set
+               `(defun ,setter ,(first set)
+                  ,@(rest set))
+               `(defun ,setter (value) (setf ,symbol value)))
+          (export ',setter)))
+     ,(let ((validator (intern (concatenate 'string "VALIDATE-" (symbol-name symbol)))))
+       `(progn
+          ,(if validate
+               `(defun ,validator ,(first validate)
+                  ,@(rest validate))
+               `(defun ,validator (value) (declare (ignore value))t))
+          (export ',validator)))
+     ,(when doc
+        `(setf (documentation ,symbol 'variable) ,doc))))
+
+(defun load-config-file (appname filename)
+  "Load `filename' from standard config path."
+  (let ((config-pathname (config-filepath appname filename)))
+    (when (probe-file config-pathname)
+      (load config-pathname))))
+
+(defun save-config-file (appname filename)
+  "Save config values to `filename'."
+  (let* ((config-pathname (config-filepath appname filename))
+         (config-string (with-open-file (stream config-pathname :if-does-not-exist nil)
+                          (when stream
+                            (let ((str (make-string (file-length stream))))
+                              (read-sequence str stream)
+                              str)))))
+    (with-open-file (stream (ensure-directories-exist config-pathname)
+                            :direction :output :if-exists :supersede)
+      (if config-string
+          (let ((pos (search config-probe config-string)))
+            (princ (subseq config-string 0 pos) stream))
+          (progn
+            (princ ";;; Configuration file for " stream)
+            (print appname stream)
+            (terpri stream)
+            (princ ";;; You are free to edit this section" stream)
+            (terpri stream)
+            (terpri stream)))
+      (princ config-probe stream)
+      (terpri stream)
+      (format stream "(in-package :~(~a~))~%" config-package)
+      (terpri stream)
+      (do-external-symbols (symbol (find-package config-package))
+        (when (boundp symbol)
+          (let ((value (symbol-value symbol)))
+            (cond
+              ((null value)
+               (format stream "(setf ~(~a~) nil)~%" (symbol-name symbol)))
+              ((eq value t)
+               (format stream "(setf ~(~a~) t)~%" (symbol-name symbol)))
+              ((or (listp value) (consp value) (symbolp value))
+               (format stream "(setf ~(~a~) '~s)~%" (symbol-name symbol) value))
+              (t
+               (format stream "(setf ~(~a~) ~s)~%" (symbol-name symbol) value))))))
+      (terpri stream))))

lisp/local-projects/sextant/sextant.asd

@@ -6,7 +6,9 @@
                     (proclaim '(optimize (debug 3) (safety 3) (speed 0)))
                     (funcall thunk))
   :depends-on #.(append (uiop:read-file-form (merge-pathnames #p"../../../dependencies.sexp" (or *load-pathname* *compile-file-pathname*)))
-                        '("sextant/editor/all"))
+                        '("sextant/editor/all")
+                        '("sextant/config/all"))
   :components ((:file "sextant")))
 
 (register-system-packages "sextant/editor/all" '(:editor))
+(register-system-packages "sextant/config/all" '(:config))