diff options
Diffstat (limited to 'module/util/config.scm')
| -rw-r--r-- | module/util/config.scm | 191 |
1 files changed, 76 insertions, 115 deletions
diff --git a/module/util/config.scm b/module/util/config.scm index f324ff63..29269ce5 100644 --- a/module/util/config.scm +++ b/module/util/config.scm @@ -1,122 +1,80 @@ ;;; Commentary: -;; This file should define all global configurable variables which -;; doesn't belong anywhere else. The config module should then import -;; this module, and set all configs as needed. The config module -;; should also be able to set configs gotten from other parts. +;; Configuration system. ;;; Code: (define-module (util config) - :use-module (srfi srfi-1) - :use-module (srfi srfi-9) - :use-module (srfi srfi-26) - :use-module (ice-9 match) - :use-module (ice-9 format) - :use-module (ice-9 curried-definitions) :use-module (util) - :export (define-config)) + :use-module (srfi srfi-1) + :use-module (ice-9 format) ; for format-procedure + :use-module (ice-9 curried-definitions) ; for ensure + :export (define-config) +) (define-once config-values (make-hash-table)) -(define-record-type <config> - (make-config value documentation source-module attributes) - config? - (value get-value set-value!) - (documentation get-documentation) - (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 -;; NOTE that it's valid to set a value (or default value) to #f -;; but that any #:pre procedure can only return #f to indicate -;; failure. -(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 - ;; might be loaded again, just anwrap it and pretend that didn't - ;; happen. - (when (,config? value) - (set! value (,get-value value))) - - (hashq-set! ,config-values (quote ,name) - (,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 '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)))]))) - - -(define* (config-attribute config attr optional: default) - (aif (memv attr (config-attributes config)) - (cadr it) - default)) +;; properties declared before being bound into hash-map +;; to allow nicer scripting in this file. -(define-public ((ensure predicate) value) - (if (not (predicate value)) - #f value)) +(define-once config-properties (make-hash-table)) +(define description (make-object-property)) +(define source-module (make-object-property)) +(define pre (make-object-property)) +(define post (make-object-property)) +(hashq-set! config-properties #:description description) +(hashq-set! config-properties #:source-module source-module) +(hashq-set! config-properties #:pre pre) +(hashq-set! config-properties #:post post) + + +;; Config cells "are" immutable. @var{set-property!} is +;; therefore intentionally unwritten. + +(define-public (get-property config-name property-key) + ((hashq-ref config-properties property-key) config-name)) + + +(define (define-config% name default-value kwargs) + (for (key value) in (group kwargs 2) + (set! ((or (hashq-ref config-properties key) + (error "Missing config protperty slot " key)) + name) + value)) + (set-config! name (get-config name default-value))) + +(define-syntax define-config + (syntax-rules () + ((_ name default kwargs ...) + (define-config% (quote name) default + (list source-module: (current-module) + kwargs ...))))) -(define-public (set-config! key value) - (cond [(hashq-ref config-values key) - => (lambda (conf) - (cond [(not value) - (set-value! conf #f) - ((config-attribute conf #:post identity) #f)] - [(unconfig? conf) - (hashq-set! config-values key - (make-unconfig value))] - [((config-attribute conf #:pre identity) - value) - => (lambda (it) - (set-value! conf it) - ((config-attribute conf #:post identity) it))] - [else - (throw 'config-error 'set-config! - "~a->~a = ~s is invalid,~%Field doc is \"~a\"" - (module-name (get-source-module conf)) - key value - (get-documentation conf))]) - )] - [else (hashq-set! config-values key (make-unconfig value))])) +(define-public (set-config! name value) + (hashq-set! config-values name + (aif (pre name) + (or (it value) (error "Pre crashed for" name)) + value)) + + (awhen (post name) (it 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) - (let ((v (hashq-ref config-values key %uniq))) - (when (eq? v %uniq) - (error "Missing config" key)) - v) - (hashq-ref config-values key default)))) - (if (config? v) - (get-value v) - v))) + (if (eq? default %uniq) + (let ((v (hashq-ref config-values key %uniq))) + (when (eq? v %uniq) + (error "Missing config" key)) + v) + (hashq-ref config-values key default))) + + + +(define-public ((ensure predicate) value) + (if (not (predicate value)) + #f value)) + + ;; (format-procedure (lambda (x y) ...)) => λx, y ;; (define (f x) ...) @@ -148,28 +106,31 @@ (export format-procedure) +(define (->str any) + (with-output-to-string + (lambda () (display any)))) + (define-public (get-configuration-documentation) (define groups - (group-by (match-lambda [(__ v) - (if (config? v) - (get-source-module v) - #f)]) - (hash-map->list list config-values )) ) - + (group-by (compose source-module car) + (hash-map->list list config-values))) `(*TOP* (header "Configuration variables") (dl ,@(concatenate (for (module values) in groups - `((dt "") (dd (header ,(format #f "~a" (module-name module)))) + `((dt "") (dd (header ,(aif module + (->str (module-name it)) + #f))) ,@(concatenate (for (key value) in values `((dt ,key) - (dd (p (@ (inline)) ,(get-documentation value))) + (dd (p (@ (inline)) + ,(or (description key) ""))) (dt "V:") - (dd ,(let ((v (get-value value))) - (if (procedure? v) - (format-procedure v) - `(scheme ,v))) + (dd ,(if (procedure? value) + (format-procedure value) + `(scheme ,value)) (br))))))))))) + |