diff options
Diffstat (limited to '')
-rw-r--r-- | module/util/config.scm | 66 | ||||
-rw-r--r-- | module/util/exceptions.scm | 5 |
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)) |