From d3cf250b9d7b28e9ac52961579f5518d7452d6a6 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Wed, 1 Apr 2020 17:07:25 +0200
Subject: Start rewrite mentioned in last commit.

---
 module/util/config.scm | 47 +++++++++++++++++++++++++++++++++++++----------
 1 file changed, 37 insertions(+), 10 deletions(-)

(limited to 'module')

diff --git a/module/util/config.scm b/module/util/config.scm
index 46c0bf99..d7b29c55 100644
--- a/module/util/config.scm
+++ b/module/util/config.scm
@@ -8,6 +8,8 @@
 ;;; Code:
 
 (define-module (util config)
+  :use-module (srfi srfi-9)
+  :use-module (util)
   :export (register-config!)
                )
 
@@ -18,13 +20,38 @@
                v (or (procedure-name pred?) ""))))
     v))
 
-(define-macro (register-config! name default-value valid-value?)
-  `(save-module-excursion
-     (lambda ()
-       (define mod (resolve-module '(util config all)))
-       (set-current-module mod)
-       (module-define! mod (quote ,name)
-                       (make-parameter ,default-value
-                                       ,valid-value?))
-       (export ,name))
-       ))
+(define-once config-values (make-hash-table))
+
+(define-record-type <config>
+  (make-config value documentation valid-value? source-module)
+  config?
+  (value get-value set-value!)
+  (documentation get-documentation)
+  (valid-value? get-valid-value)
+  (source-module get-source-module))
+
+
+;; similar to emacs defcustom
+;; TODO possibly make @var{documentation} and @var{valid-value?} optional.
+(define-macro (define-config name default-value documentation valid-value?)
+  `(let ((make-config (@@ (util config) make-config))
+         (config-values (@@ (util config) config-values)))
+     (cond [(hashq-ref config-values (quote ,name))
+            => (lambda (value)
+                 (unless (,valid-value? value)
+                   (throw 'config-error
+                          "Config [~a]: ~a doesn't sattisfy predicate ~s~%\"~a\"~%"
+                          (quote ,name)
+                          value
+                          ,valid-value?
+                          ,documentation))
+                 (hashq-set! config-values (quote ,name)
+                             (make-config value ,documentation
+                                          ,valid-value? (current-module))))]
+           ;; value not set in advance
+           [else
+            (hashq-set! config-values (quote ,name)
+                        (make-config ,default-value ,documentation
+                                     ,valid-value? (current-module)))])))
+
+(export define-config)
-- 
cgit v1.2.3