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