Merge branch 'master' into calchooser

11 files changed, 172 insertions, 132 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 3fac17bb..fdaea217 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)
@@ -180,12 +181,14 @@
                         title: "Stäng"
                         onclick: "close_popup(document.getElementById(this.closest('.popup-container').id))"
                         class: '("close-tooltip"))
-                  ,(btn "🖊️"
-                        title: "Redigera"
-                        onclick: "place_in_edit_mode(document.getElementById(this.closest('.popup-container').id.substr(5)))")
-                  ,(btn "🗑"
-                        title: "Ta bort"
-                        onclick: "remove_event(document.getElementById(this.closest('.popup-container').id.substr(5)))"))
+                  ,(when (edit-mode)
+                     (list
+                      (btn "🖊️"
+                           title: "Redigera"
+                           onclick: "place_in_edit_mode(document.getElementById(this.closest('.popup-container').id.substr(5)))")
+                      (btn "🗑"
+                           title: "Ta bort"
+                           onclick: "remove_event(document.getElementById(this.closest('.popup-container').id.substr(5)))"))))
 
              ,(tabset
                 `(("📅" title: "Översikt"
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)
          )
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..29269ce5 100644
--- a/module/util/config.scm
+++ b/module/util/config.scm
@@ -1,122 +1,80 @@
 ;;; 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 (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 curried-definitions)
   :use-module (util)
-  :export (define-config))
+  :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))
 
-(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))
+;; properties declared before being bound into hash-map
+;; to allow nicer scripting in this file.
 
-(define-public ((ensure predicate) value)
-  (if (not (predicate value))
-      #f value))
+(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! 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))]))
+(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))
-  (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)))
+  (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) ...)
@@ -148,28 +106,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)))))))))))
+
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
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."))