From 8b397e05a8e80b5d50cdbf94d8858c617c5ebafd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Wed, 12 Aug 2020 01:06:39 +0200 Subject: Massivly simplify config internals. --- module/util/config.scm | 142 ++++++++++++++++--------------------------------- 1 file changed, 46 insertions(+), 96 deletions(-) (limited to 'module/util/config.scm') diff --git a/module/util/config.scm b/module/util/config.scm index f324ff63..462ed1d0 100644 --- a/module/util/config.scm +++ b/module/util/config.scm @@ -13,110 +13,59 @@ :use-module (srfi srfi-26) :use-module (ice-9 match) :use-module (ice-9 format) - :use-module (ice-9 curried-definitions) + :use-module (ice-9 curried-definitions) ; for ensure :use-module (util) - :export (define-config)) + :export (define-config) +) (define-once config-values (make-hash-table)) - -(define-record-type - (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 - (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)) +(define-once config-properties (make-hash-table)) +(hashq-set! config-properties #:description (make-object-property)) +(hashq-set! config-properties #:source-module (make-object-property)) +(hashq-set! config-properties #:pre (make-object-property)) +(hashq-set! config-properties #:post (make-object-property)) + +(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! name value) + (hashq-set! config-values name + (aif (get-property name #:pre) + (or (it value) (error "Pre crashed for" name)) + value)) + + (awhen (get-property name #:post) + (it value))) +;; unique symbol here since #f is a valid configuration value. +(define %uniq (gensym)) +(define*-public (get-config key optional: (default %uniq)) + (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)) -(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))])) - -;; 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))) + ;; (format-procedure (lambda (x y) ...)) => λx, y ;; (define (f x) ...) @@ -173,3 +122,4 @@ (format-procedure v) `(scheme ,v))) (br))))))))))) + -- cgit v1.2.3 From 38e252927d2f481fd267279a390deea20eb898e1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Wed, 12 Aug 2020 01:23:37 +0200 Subject: fixups in (util config). --- module/util/config.scm | 55 +++++++++++++++++++++++++++++++++----------------- 1 file changed, 36 insertions(+), 19 deletions(-) (limited to 'module/util/config.scm') diff --git a/module/util/config.scm b/module/util/config.scm index 462ed1d0..ae34963c 100644 --- a/module/util/config.scm +++ b/module/util/config.scm @@ -19,15 +19,28 @@ ) (define-once config-values (make-hash-table)) + +;; properties declared before being bound into hash-map +;; to allow nicer scripting in this file. + (define-once config-properties (make-hash-table)) -(hashq-set! config-properties #:description (make-object-property)) -(hashq-set! config-properties #:source-module (make-object-property)) -(hashq-set! config-properties #:pre (make-object-property)) -(hashq-set! config-properties #:post (make-object-property)) +(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) @@ -45,12 +58,12 @@ (define-public (set-config! name value) (hashq-set! config-values name - (aif (get-property name #:pre) + (aif (pre name) (or (it value) (error "Pre crashed for" name)) value)) - (awhen (get-property name #:post) - (it 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)) @@ -61,6 +74,8 @@ v) (hashq-ref config-values key default))) + + (define-public ((ensure predicate) value) (if (not (predicate value)) #f value)) @@ -97,29 +112,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))))))))))) -- cgit v1.2.3 From 295b65b9ec50418d71f3db221579ada3ff60f58e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Wed, 12 Aug 2020 01:29:04 +0200 Subject: cleanup. --- module/util/config.scm | 12 +++--------- 1 file changed, 3 insertions(+), 9 deletions(-) (limited to 'module/util/config.scm') diff --git a/module/util/config.scm b/module/util/config.scm index ae34963c..29269ce5 100644 --- a/module/util/config.scm +++ b/module/util/config.scm @@ -1,20 +1,14 @@ ;;; 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 (util) :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 format) ; for format-procedure :use-module (ice-9 curried-definitions) ; for ensure - :use-module (util) :export (define-config) ) -- cgit v1.2.3