diff options
Diffstat (limited to 'module/util/config.scm')
-rw-r--r-- | module/util/config.scm | 136 |
1 files changed, 0 insertions, 136 deletions
diff --git a/module/util/config.scm b/module/util/config.scm deleted file mode 100644 index 29269ce5..00000000 --- a/module/util/config.scm +++ /dev/null @@ -1,136 +0,0 @@ -;;; Commentary: - -;; Configuration system. - -;;; Code: - -(define-module (util config) - :use-module (util) - :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)) - -;; properties declared before being bound into hash-map -;; to allow nicer scripting in this file. - -(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! 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)) - (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) ...) -;; (format-procedure f) => f(x) -(define (format-procedure proc) - ((aif (procedure-name proc) - (lambda (s) (string-append (symbol->string it) "(" s ")")) - (lambda (s) (string-append "λ" s))) - (let ((args ((@ (ice-9 session) procedure-arguments) - proc))) - (string-join - (remove null? - (list - (awhen ((ensure (negate null?)) - (assoc-ref args 'required)) - (format #f "~{~a~^, ~}" it)) - (awhen ((ensure (negate null?)) - (assoc-ref args 'optional)) - (format #f "[~{~a~^, ~}]" it)) - (awhen ((ensure (negate null?)) - (assoc-ref args 'keyword)) - (format #f "key: ~{~a~^, ~}" - (map keyword->symbol - (map car it)))) - (awhen ((ensure (negate null?)) - (assoc-ref args 'rest)) - (format #f "~a ..." it)))) - ", ")))) - -(export format-procedure) - -(define (->str any) - (with-output-to-string - (lambda () (display any)))) - -(define-public (get-configuration-documentation) - (define groups - (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 ,(aif module - (->str (module-name it)) - #f))) - ,@(concatenate - (for (key value) in values - `((dt ,key) - (dd (p (@ (inline)) - ,(or (description key) ""))) - (dt "V:") - (dd ,(if (procedure? value) - (format-procedure value) - `(scheme ,value)) - (br))))))))))) - |