Slight changes to define-config.

2 files changed, 52 insertions, 19 deletions

diff --git a/module/util/config.scm b/module/util/config.scm
index 3ac78e31..af93ef41 100644
--- a/module/util/config.scm
+++ b/module/util/config.scm
@@ -13,26 +13,33 @@
   :use-module (ice-9 match)
   :use-module (ice-9 format)
   :use-module (util)
+  :use-module (util exceptions)
                )
 
 (define-once config-values (make-hash-table))
 
 (define-record-type <config>
-  (make-config value documentation valid-value? source-module)
+  (make-config value documentation source-module attributes)
   config?
   (value get-value set-value!)
   (documentation get-documentation)
-  (valid-value? get-valid-value)
-  (source-module get-source-module))
+  (source-module get-source-module)
+  (attributes config-attributes)
+  )
+
+(define-record-type <un-config>
+  (make-unconfig value)
+  unconfig?
+  (value get-un-value))
 
 
 ;; similar to emacs defcustom
-;; TODO possibly make @var{documentation} and @var{valid-value?} optional.
-(define-macro (define-config name default-value documentation valid-value?)
+(define-macro (define-config name default-value documentation . rest)
   (let ((make-config '(@@ (util config) make-config))
         (config-values '(@@ (util config) config-values))
         (config? '(@@ (util config) config?))
         (get-value '(@@ (util config) get-value)))
+
     `(cond [(hashq-ref ,config-values (quote ,name))
             => (lambda (value)
                  ;; When reloading a module an already defined configuration item
@@ -41,30 +48,51 @@
                  (when (,config? value)
                    (set! value (,get-value value)))
 
-                 (unless (,valid-value? value)
-                   (scm-error 'config-error 'define-config
-                              "Config [~a]: ~a doesn't sattisfy predicate ~s~%\"~a\"~%"
-                              (list (quote ,name)
-                                    value
-                                    ,valid-value?
-                                    ,documentation)
-                              (list value)))
                  (hashq-set! ,config-values (quote ,name)
-                             (,make-config value ,documentation
-                                           ,valid-value? (current-module))))]
+                             (,make-config 'dummy ,documentation (current-module)
+                                           (list ,@rest)))
+
+                 ;; Fatal error when the default value doesn't work.
+                 (catch 'config-error
+                   (lambda () (set-config! (quote ,name) value))
+                   (lambda (err _ fmt args __)
+                     (apply (@ (util exceptions) fatal) fmt args))))]
+
            ;; value not set in advance
            [else
             (hashq-set! ,config-values (quote ,name)
-                        (,make-config ,default-value ,documentation
-                                      ,valid-value? (current-module)))])))
+                        (,make-config 'dummy ,documentation
+                                      (current-module) (list ,@rest)))
+            (catch 'config-error
+              (lambda () (set-config! (quote ,name) ,default-value))
+              (lambda (err _ fmt args __)
+                ((@ (util exceptions) fatal) "~a ~a" fmt args)))])))
+
 
 (export define-config)
 
+(define* (config-attribute config attr optional: default)
+  (aif (memv attr (config-attributes config))
+       (cadr it)
+       default))
+
 (define-public (set-config! key value)
   (cond [(hashq-ref config-values key)
-         => (cut set-value! <> value)]
-        [else (hashq-set! config-values key value)]))
+         => (lambda (conf)
+              (aif (not ((config-attribute conf #:pre (const #t))
+                         value))
+                   (scm-error 'config-error 'define-config
+                              "Config [~a]: ~a doesn't sattisfy predicate ~s~%\"~a\"~%"
+                              (list (quote ,name)
+                                    value
+                                    (get-documentation conf))
+                              (list value))
+                   (begin
+                     (set-value! conf value)
+                     ((config-attribute conf #:post identity) value))))]
+        [else (hashq-set! config-values key (make-unconfig value))]))
 
+;; unique symbol here since #f is a valid configuration value.
 (define %uniq (gensym))
 (define*-public (get-config key optional: (default %uniq))
   (let ((v (if (eq? default %uniq)
diff --git a/module/util/exceptions.scm b/module/util/exceptions.scm
index d45fb641..a5605e48 100644
--- a/module/util/exceptions.scm
+++ b/module/util/exceptions.scm
@@ -53,6 +53,11 @@
   (display (apply (warning-handler) fmt (or args '()))
            (current-error-port)))
 
+(define-public (fatal fmt . args)
+  (display (format #f "FATAL: ~?~%" fmt (or args '()))
+           (current-error-port))
+  (raise 2)
+  )
 
 (define (prettify-tree tree)
   (cond [(pair? tree) (cons (prettify-tree (car tree))