Slight changes to define-config.

5 files changed, 60 insertions, 28 deletions

diff --git a/module/datetime/util.scm b/module/datetime/util.scm
index a4ac8bcc..4f461591 100644
--- a/module/datetime/util.scm
+++ b/module/datetime/util.scm
@@ -101,14 +101,12 @@
   )
 
 
+(define-public week-start (make-parameter sun))
+
 (define-config week-start sun
   "First day of week"
-  (lambda (x) (<= sun x sat)))
-
-;; TODO setting the @var{week-start} parameter from the @var{week-start}
-;; config ought to be done. But a post-set method first needs to be
-;; introduced in define-config.
-(define-public week-start (make-parameter sun))
+  pre: (lambda (x) (<= sun x sat))
+  post: week-start)
 
 ;; given a date, returns the date the first week of that year starts on.
 ;; @example
diff --git a/module/output/html.scm b/module/output/html.scm
index 045e1160..64859c2d 100644
--- a/module/output/html.scm
+++ b/module/output/html.scm
@@ -26,11 +26,11 @@
 
 (define-config summary-filter (lambda (_ a) a)
   ""
-  procedure?)
+  pre: procedure?)
 
 (define-config description-filter (lambda (_ a) a)
   ""
-  procedure?)
+  pre: procedure?)
 
 (define debug (make-parameter #f))
 
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))
diff --git a/module/vcomponent/load.scm b/module/vcomponent/load.scm
index 09dcd3c8..f90d7d46 100644
--- a/module/vcomponent/load.scm
+++ b/module/vcomponent/load.scm
@@ -4,7 +4,8 @@
   :use-module (util config)
   :use-module ((vcomponent parse) :select (parse-cal-path)))
 
-(define-config calendar-files '() "" list?)
+(define-config calendar-files '() ""
+  pre: list?)
 
 (define* (load-calendars calendar-files)
   (map parse-cal-path calendar-files))