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/datetime.scm | 3 +- module/datetime/instance.scm | 4 +- module/html/config.scm | 4 +- module/html/vcomponent.scm | 8 +- module/util.scm | 5 ++ module/util/config.scm | 142 +++++++++++----------------------- module/util/exceptions.scm | 2 +- module/vcomponent.scm | 2 +- module/vcomponent/datetime/output.scm | 2 - 9 files changed, 63 insertions(+), 109 deletions(-) diff --git a/module/datetime.scm b/module/datetime.scm index a0b1e533..5a821afb 100644 --- a/module/datetime.scm +++ b/module/datetime.scm @@ -49,9 +49,8 @@ ;;; Configuration (define-public week-start (make-parameter sun)) - (define-config week-start sun - "First day of week" + description: "First day of week" pre: (ensure (lambda (x) (<= sun x sat))) post: week-start) diff --git a/module/datetime/instance.scm b/module/datetime/instance.scm index 048c9a9b..829002b9 100644 --- a/module/datetime/instance.scm +++ b/module/datetime/instance.scm @@ -5,10 +5,10 @@ :export (zoneinfo)) (define-config tz-dir #f - "Directory in which zoneinfo files can be found") + description: "Directory in which zoneinfo files can be found") (define-config tz-list '() - "List of default zoneinfo files to be parsed") + description: "List of default zoneinfo files to be parsed") (define / file-name-separator-string) diff --git a/module/html/config.scm b/module/html/config.scm index 3ae0e1da..03e18db7 100644 --- a/module/html/config.scm +++ b/module/html/config.scm @@ -5,7 +5,7 @@ (define-public debug (make-parameter #f)) (define-config debug #f - "Places the generated thingy in debug mode" + description: "Places the generated thingy in debug mode" post: debug) @@ -13,6 +13,6 @@ ;;; but this works for the time being. (define-public edit-mode (make-parameter #t)) (define-config edit-mode #t - "Makes the document editable" + description: "Makes the document editable" post: edit-mode) diff --git a/module/html/vcomponent.scm b/module/html/vcomponent.scm index f9c24ecd..9189b59e 100644 --- a/module/html/vcomponent.scm +++ b/module/html/vcomponent.scm @@ -5,6 +5,7 @@ :use-module (srfi srfi-41) :use-module (datetime) :use-module (html util) + :use-module ((html config) :select (edit-mode)) :use-module ((html components) :select (btn tabset)) :use-module ((output general) :select (calculate-fg-color)) :use-module ((vcomponent datetime output) @@ -174,9 +175,10 @@ title: "Stäng" onclick: "close_popup(document.getElementById(this.closest('.popup-container').id))" class: '("close-tooltip")) - ,(btn "🗑" - title: "Ta bort" - onclick: "remove_event(document.getElementById(this.closest('.popup-container').id.substr(5)))")) + ,(when (edit-mode) + (btn "🗑" + title: "Ta bort" + onclick: "remove_event(document.getElementById(this.closest('.popup-container').id.substr(5)))"))) ,(tabset `(("📅" title: "Översikt" diff --git a/module/util.scm b/module/util.scm index 04d13220..fce1c014 100644 --- a/module/util.scm +++ b/module/util.scm @@ -486,6 +486,11 @@ (and=>> (and=> value proc) rest ...)])) +;; @example +;; (group (iota 10) 2) +;; ⇒ ((0 1) (2 3) (4 5) (6 7) (8 9)) +;; @end example +;; Requires that width|(length list) (define-public (group list width) (unless (null? list) (let* ((row rest (split-at list width))) 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))))))))))) + diff --git a/module/util/exceptions.scm b/module/util/exceptions.scm index 46d3fede..8db18605 100644 --- a/module/util/exceptions.scm +++ b/module/util/exceptions.scm @@ -52,7 +52,7 @@ (make-parameter #f)) (define-config warnings-are-errors #f - "Crash on warnings." + description: "Crash on warnings." post: warnings-are-errors) ;; forwards return from warning-hander. By default returns an unspecified value, diff --git a/module/vcomponent.scm b/module/vcomponent.scm index 1272cea1..66b72162 100644 --- a/module/vcomponent.scm +++ b/module/vcomponent.scm @@ -11,7 +11,7 @@ (vcomponent instance methods)) (define-config calendar-files '() - "Which files to parse. Takes a list of paths or a single string which will be globbed." + description: "Which files to parse. Takes a list of paths or a single string which will be globbed." pre: (lambda (v) (cond [(list? v) v] [(string? v) ((@ (glob) glob) v)] diff --git a/module/vcomponent/datetime/output.scm b/module/vcomponent/datetime/output.scm index eb127ceb..48c89783 100644 --- a/module/vcomponent/datetime/output.scm +++ b/module/vcomponent/datetime/output.scm @@ -8,11 +8,9 @@ ) (define-config summary-filter (lambda (_ a) a) - "" pre: (ensure procedure?)) (define-config description-filter (lambda (_ a) a) - "" pre: (ensure procedure?)) ;; ev → sxml -- 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(-) 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 1cf8daa95e821fa6894a253287a4271897a99fc5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 11 Aug 2020 16:29:14 +0200 Subject: Add script for finding config entries. --- scripts/get-config.scm | 69 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 69 insertions(+) create mode 100755 scripts/get-config.scm diff --git a/scripts/get-config.scm b/scripts/get-config.scm new file mode 100755 index 00000000..6d9c3290 --- /dev/null +++ b/scripts/get-config.scm @@ -0,0 +1,69 @@ +#!/usr/bin/guile \ +-s +!# + +;;; Commentary: +;;; Script for finding all top level `config' forms. Run this from the +;;; project root. +;;; Code: + + +(add-to-load-path "module") + +(use-modules + (util) + (ice-9 ftw) + (ice-9 match) + (srfi srfi-1) + ) + +(define (read-multiple) + (let loop ((done '())) + (let ((sexp (read))) + (if (eof-object? sexp) + (reverse done) + (loop (cons sexp done)))))) + +(define remove-stat + (match-lambda + ((name state) name) + ((name stat children ...) + (cons name (map remove-stat children))))) + +(define (f tree) + (let loop ((rem tree) (path '())) + (cond [(string? rem) + (string-join (reverse (cons rem path)) "/" 'infix)] + [(null? rem) + '()] + [else + (map (lambda (branch) + (loop branch (cons (car rem) path))) + (cdr rem))]))) + + +((@ (ice-9 pretty-print) pretty-print) + (filter + (lambda (form) + (and (list? form) (not (null? form)) + (eq? 'define-config (car form)))) + (concatenate + (map (lambda (filename) (with-input-from-file filename read-multiple)) + (flatten (f (remove-stat (file-system-tree "module")))))))) + +;; expected result => +#; +((config debug) + (config edit-mode) + (config summary-filter) + (config description-filter) + (config + tz-dir + "Directory in which zoneinfo files can be found") + (config + tz-list + "List of default zoneinfo files to be parsed") + (config default-week-start "First day of week") + (config + calendar-files + "Which files to parse. Takes a list of paths or a single string which will be globbed.")) -- cgit v1.2.3 From 5d81c51050704697a79e0fac4dedb535921a0d46 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Wed, 12 Aug 2020 01:26:52 +0200 Subject: Add NOTE about get-configuration-documentation. --- module/main.scm | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/module/main.scm b/module/main.scm index 98a07c44..5455b20a 100644 --- a/module/main.scm +++ b/module/main.scm @@ -147,7 +147,12 @@ (display (sxml->ansi-text module-help) (current-output-port)) (print-arg-help options) - (display (sxml->ansi-text (get-configuration-documentation)) + (display (sxml->ansi-text + ;; NOTE that this can only display config + ;; items in loaded modules. + ;; See scripts/get-config.scm for finding + ;; all configuration items. + (get-configuration-documentation)) (current-output-port)) (throw 'return) ) -- 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(-) 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