From 4ba8a8894f0a63e0d3e96df38c3c4d5dab5b737c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sat, 23 May 2020 21:46:05 +0200 Subject: Slight changes to define-config. --- module/datetime/util.scm | 10 +++---- module/output/html.scm | 4 +-- module/util/config.scm | 66 +++++++++++++++++++++++++++++++++------------- module/util/exceptions.scm | 5 ++++ module/vcomponent/load.scm | 3 ++- 5 files changed, 60 insertions(+), 28 deletions(-) (limited to 'module') diff --git a/module/datetime/util.scm b/module/datetime/util.scm index a4ac8bcc..4f461591 100644 --- a/module/datetime/util.scm +++ b/module/datetime/util.scm @@ -101,14 +101,12 @@ ) +(define-public week-start (make-parameter sun)) + (define-config week-start sun "First day of week" - (lambda (x) (<= sun x sat))) - -;; TODO setting the @var{week-start} parameter from the @var{week-start} -;; config ought to be done. But a post-set method first needs to be -;; introduced in define-config. -(define-public week-start (make-parameter sun)) + pre: (lambda (x) (<= sun x sat)) + post: week-start) ;; given a date, returns the date the first week of that year starts on. ;; @example diff --git a/module/output/html.scm b/module/output/html.scm index 045e1160..64859c2d 100644 --- a/module/output/html.scm +++ b/module/output/html.scm @@ -26,11 +26,11 @@ (define-config summary-filter (lambda (_ a) a) "" - procedure?) + pre: procedure?) (define-config description-filter (lambda (_ a) a) "" - procedure?) + pre: procedure?) (define debug (make-parameter #f)) diff --git a/module/util/config.scm b/module/util/config.scm index 3ac78e31..af93ef41 100644 --- a/module/util/config.scm +++ b/module/util/config.scm @@ -13,26 +13,33 @@ :use-module (ice-9 match) :use-module (ice-9 format) :use-module (util) + :use-module (util exceptions) ) (define-once config-values (make-hash-table)) (define-record-type - (make-config value documentation valid-value? source-module) + (make-config value documentation source-module attributes) config? (value get-value set-value!) (documentation get-documentation) - (valid-value? get-valid-value) - (source-module get-source-module)) + (source-module get-source-module) + (attributes config-attributes) + ) + +(define-record-type + (make-unconfig value) + unconfig? + (value get-un-value)) ;; similar to emacs defcustom -;; TODO possibly make @var{documentation} and @var{valid-value?} optional. -(define-macro (define-config name default-value documentation valid-value?) +(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 @@ -41,30 +48,51 @@ (when (,config? value) (set! value (,get-value value))) - (unless (,valid-value? value) - (scm-error 'config-error 'define-config - "Config [~a]: ~a doesn't sattisfy predicate ~s~%\"~a\"~%" - (list (quote ,name) - value - ,valid-value? - ,documentation) - (list value))) (hashq-set! ,config-values (quote ,name) - (,make-config value ,documentation - ,valid-value? (current-module))))] + (,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 ,default-value ,documentation - ,valid-value? (current-module)))]))) + (,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)))]))) + (export define-config) +(define* (config-attribute config attr optional: default) + (aif (memv attr (config-attributes config)) + (cadr it) + default)) + (define-public (set-config! key value) (cond [(hashq-ref config-values key) - => (cut set-value! <> value)] - [else (hashq-set! config-values key value)])) + => (lambda (conf) + (aif (not ((config-attribute conf #:pre (const #t)) + value)) + (scm-error 'config-error 'define-config + "Config [~a]: ~a doesn't sattisfy predicate ~s~%\"~a\"~%" + (list (quote ,name) + value + (get-documentation conf)) + (list value)) + (begin + (set-value! conf value) + ((config-attribute conf #:post identity) value))))] + [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) diff --git a/module/util/exceptions.scm b/module/util/exceptions.scm index d45fb641..a5605e48 100644 --- a/module/util/exceptions.scm +++ b/module/util/exceptions.scm @@ -53,6 +53,11 @@ (display (apply (warning-handler) fmt (or args '())) (current-error-port))) +(define-public (fatal fmt . args) + (display (format #f "FATAL: ~?~%" fmt (or args '())) + (current-error-port)) + (raise 2) + ) (define (prettify-tree tree) (cond [(pair? tree) (cons (prettify-tree (car tree)) diff --git a/module/vcomponent/load.scm b/module/vcomponent/load.scm index 09dcd3c8..f90d7d46 100644 --- a/module/vcomponent/load.scm +++ b/module/vcomponent/load.scm @@ -4,7 +4,8 @@ :use-module (util config) :use-module ((vcomponent parse) :select (parse-cal-path))) -(define-config calendar-files '() "" list?) +(define-config calendar-files '() "" + pre: list?) (define* (load-calendars calendar-files) (map parse-cal-path calendar-files)) -- cgit v1.2.3