Massivly simplify config internals.

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 <config>
-  (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 <un-config>
-  (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