diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2020-05-23 21:46:05 +0200 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2020-05-23 21:46:05 +0200 |
commit | 4ba8a8894f0a63e0d3e96df38c3c4d5dab5b737c (patch) | |
tree | 3b04c18d026fa2505f49ab88eebca4ccc92a1526 /module/util/config.scm | |
parent | Add tests for with-replaced-attrs. (diff) | |
download | calp-4ba8a8894f0a63e0d3e96df38c3c4d5dab5b737c.tar.gz calp-4ba8a8894f0a63e0d3e96df38c3c4d5dab5b737c.tar.xz |
Slight changes to define-config.
Diffstat (limited to '')
-rw-r--r-- | module/util/config.scm | 66 |
1 files changed, 47 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) |