Replace config system with paramater based system.

This new setup stores all configurations are parameters. This forces
everything into modules, and ensures that we can't have a module use an
unloaded config. It (unfortunatelly) also causes users to have to
specify namespaces when defining values, but ini-files (and the like)
already does that. Also, there is nothing stopping a new `set-config!'
from being defined which allows un-namespaced operation.

The commit also removes the introspection procedures. They where a bit
weird to begin with, since they only showed loaded fields. And since the
program had no way of properly serializing or deserializing them we
remove them for the time being. They would however be good to
reintroduce together with a proper menu for editing simple
configuration (see Emacs' `custom-set-variables').

15 files changed, 110 insertions, 219 deletions

diff --git a/module/calp/entry-points/server.scm b/module/calp/entry-points/server.scm
index 1888a8a7..a4e8137a 100644
--- a/module/calp/entry-points/server.scm
+++ b/module/calp/entry-points/server.scm
@@ -38,9 +38,8 @@ and <i>[::]</i> for IPv6</group>"))))
 
   (define opts (getopt-long args (getopt-opt options)))
   (define addr (option-ref opts 'addr #f))
-  (define port (or (and=> (option-ref opts 'port #f)
-                          string->number)
-                   (get-config 'port)))
+  (define port (cond ((option-ref opts 'port #f) => string->number)
+                     (else (port))))
   (define family
     (cond [(option-ref opts 'six  #f) AF_INET6]
           [(option-ref opts 'four #f) AF_INET]
diff --git a/module/calp/html/config.scm b/module/calp/html/config.scm
index 08a4b2e8..c5a4e4c0 100644
--- a/module/calp/html/config.scm
+++ b/module/calp/html/config.scm
@@ -4,16 +4,11 @@
   :use-module (calp translation)
   )
 
-(define-public debug (make-parameter #f))
 (define-config debug #f
-  description: (_ "Places the generated thingy in debug mode")
-  post: debug)
+  description: (_ "Places the generated thingy in debug mode"))
 
 
 ;;; NOTE edit mode should preferably depend on login-status of the user
 ;;; but this works for the time being.
-(define-public edit-mode (make-parameter #t))
 (define-config edit-mode #t
-  description: (_ "Makes the document editable")
-  post: edit-mode)
-
+  description: (_ "Makes the document editable"))
diff --git a/module/calp/html/filter.scm b/module/calp/html/filter.scm
new file mode 100644
index 00000000..a3ef6209
--- /dev/null
+++ b/module/calp/html/filter.scm
@@ -0,0 +1,9 @@
+(define-module (calp html filter)
+  :use-module (calp util config)
+  )
+
+(define-config summary-filter (lambda (_ a) a)
+  pre: (ensure procedure?))
+
+(define-config description-filter (lambda (_ a) a)
+  pre: (ensure procedure?))
diff --git a/module/calp/html/vcomponent.scm b/module/calp/html/vcomponent.scm
index 16189dff..91db44e6 100644
--- a/module/calp/html/vcomponent.scm
+++ b/module/calp/html/vcomponent.scm
@@ -25,22 +25,17 @@
   :use-module ((base64) :select (base64encode))
   :use-module (ice-9 format)
   :use-module (calp translation)
+  :use-module (calp html filter)
   )
 
-(define-config summary-filter (lambda (_ a) a)
-  pre: (ensure procedure?))
-
-(define-config description-filter (lambda (_ a) a)
-  pre: (ensure procedure?))
-
 
 (define-public (format-summary ev str)
-  ((get-config 'summary-filter) ev str))
+  ((summary-filter) ev str))
 
 ;; NOTE this should have information about context (html/term/...)
 ;; And then be moved somewhere else.
 (define-public (format-description ev str)
-  (catch* (lambda () ((get-config 'description-filter) ev str))
+  (catch* (lambda () ((description-filter) ev str))
           (configuration-error
            (lambda (key subr msg args data)
              (format (current-error-port)
@@ -396,7 +391,7 @@
                (select (@ (class "calendar-selection"))
                  ;; NOTE flytta "muffarna" utanför
                  (option ,(_ "- Choose a Calendar -"))
-                 ,@(let ((dflt (get-config 'default-calendar)))
+                 ,@(let ((dflt ((@ (vcomponent) default-calendar))))
                      (map (lambda (calendar)
                             (define name (prop calendar 'NAME))
                             `(option (@ (value ,(base64encode name))
diff --git a/module/calp/html/view/calendar.scm b/module/calp/html/view/calendar.scm
index d4ad2977..aef33f36 100644
--- a/module/calp/html/view/calendar.scm
+++ b/module/calp/html/view/calendar.scm
@@ -107,7 +107,7 @@
 EDIT_MODE=~:[false~;true~];
 window.default_calendar='~a';"
               (edit-mode)
-              (base64encode (get-config 'default-calendar))))
+              (base64encode ((@ (vcomponent) default-calendar)))))
 
 
     (style ,(format #f "html {
diff --git a/module/calp/main.scm b/module/calp/main.scm
index e5388ae0..9b3676dd 100644
--- a/module/calp/main.scm
+++ b/module/calp/main.scm
@@ -6,7 +6,6 @@
   :use-module (srfi srfi-1)
   :use-module (srfi srfi-88)             ; keyword syntax
 
-  :use-module ((calp util config) :select (set-config! get-config get-configuration-documentation))
   :use-module (hnh util options)
   :use-module ((calp util hooks) :select (shutdown-hook))
 
@@ -50,16 +49,13 @@ contain all events.
             (description
              ,(_ "Path to alterantive configuration file to load instead of the default one.")))
 
-    ;; Techical note:
-    ;; Guile's getopt doesn't support repeating keys. Thereby the small jank,
-    ;; and my regex hack below.
-    (option (single-char #\o)
-            (value #t)
-            (description
-             ,(xml->sxml (_ "<group>Set configuration options, on the form <i>key</i>=<i>value</i>
-as if they were set in the config file. These options have priority over those
-from the file.  Can <i>not</i> be given with an equal after --option.  <br/>Can
-be given multiple times.</group>"))))
+    (debug (single-char #\d)
+           (description
+            ,(_ "Turns on debug mode for HTML output")))
+
+    (edit-mode
+     (description
+      ,(_ "Makes generated HTML user editable (through JS)")))
 
     (version (single-char #\v)
              (description ,(format #f (_ "Display version, which is ~a btw.")
@@ -70,10 +66,7 @@ be given multiple times.</group>"))))
     (help (single-char #\h)
           (description ,(_ "Print this help")))
 
-    (printconf (description ,(xml->sxml (_ "<group>Print known configuration variables.
-<br/><b>NOTE</b>:
-Only those configuration variables which are loaded will be shown, more might be
-available</group>"))))))
+    ))
 
 (define module-help
   (xml->sxml
@@ -176,22 +169,12 @@ the same code as <b>ical</b>.</p>")
               args
               )))
 
+  (awhen (option-ref opts 'edit-mode #f)
+         ((@ (calp html config) edit-mode) #t))
 
+  (awhen (option-ref opts 'debug #f)
+         ((@ (calp html config) debug) #t))
 
-  ;; NOTE this doesn't stop at first non-option, meaning that -o flags
-  ;; from sub-commands might be parsed.
-  (map (lambda (pair)
-         (let* (((key value) (string-split (cadr pair) #\=)))
-           (set-config! (string->symbol key)
-                        (let ((form (call-with-input-string value read)))
-                          (if (list? form)
-                              (primitive-eval form)
-                              form)))))
-       (filter (lambda (p)
-                 ;; should match `--option', as well as a single flag with any
-                 ;; number of other options, as long as the last one is `o'.
-                 (string-match "^-(-option|[^-]*o)$" (car p)))
-               (zip args (cdr args))))
 
   ;; help printing moved below some other stuff to allow
   ;; print-configuration-and-return to show bound values.
@@ -201,16 +184,6 @@ the same code as <b>ical</b>.</p>")
          (print-arg-help options)
          (throw 'return))
 
-  (awhen (option-ref opts 'printconf #f)
-         (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))
-
   (when (option-ref opts 'version #f)
     (format #t (_ "Calp version ~a~%") (@ (calp) version))
     (throw 'return))
@@ -230,8 +203,9 @@ the same code as <b>ical</b>.</p>")
       ((@ (hnh util io) with-atomic-output-to-file)
        (path-append (xdg-data-home) "calp" "zoneinfo.scm")
        (lambda ()
-         (write `(set-config! 'tz-list ',names)) (newline)
-         (write `(set-config! 'last-zoneinfo-upgrade ,((@ (datetime) current-date)))) (newline)))))
+         (write `((@ (datetime instance) tz-list) ',names)) (newline)
+         ;; (write `(set-config! 'last-zoneinfo-upgrade ,((@ (datetime) current-date)))) (newline)
+         ))))
 
   ;; always load zoneinfo if available.
   (let ((z (path-append (xdg-data-home) "calp" "zoneinfo.scm")))
diff --git a/module/calp/server/routes.scm b/module/calp/server/routes.scm
index e3237914..8c416585 100644
--- a/module/calp/server/routes.scm
+++ b/module/calp/server/routes.scm
@@ -111,12 +111,8 @@
 
 
 
-(define static-dir (make-parameter "static"))
-
 (define-config static-dir "static"
-  description: "Where static files for the web server are located"
-  post: static-dir
-  )
+  description: (_ "Where static files for the web server are located"))
 
 
 
diff --git a/module/calp/util/config.scm b/module/calp/util/config.scm
index 3bc55d92..b2a46ea7 100644
--- a/module/calp/util/config.scm
+++ b/module/calp/util/config.scm
@@ -7,143 +7,58 @@
 (define-module (calp util config)
   :use-module (hnh util)
   :use-module (srfi srfi-1)
-  :use-module (ice-9 format) ; for format-procedure
   :use-module (ice-9 curried-definitions) ; for ensure
   :use-module (calp translation)
   :export (define-config)
 )
 
-(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))
-(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)
-       (aif (hashq-ref config-properties key)
-            (set! (it name) value)
-            (scm-error 'configuration-error
-                       "define-config"
-                       (_ "No configuration slot named ~s, when defining ~s")
-                       (list key name)
-                       #f)))
-  (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 (pre name)
-                   (or (it value)
-                       (scm-error 'configuration-error
-                                  "set-config!"
-                                  ;; first slot is property name, second is new
-                                  ;; property value.
-                                  (_ "Pre-property failed when setting ~s to ~s")
-                                  (list name value)
-                                  #f))
-                   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))
-  (if (eq? default %uniq)
-      (let ((v (hashq-ref config-values key %uniq)))
-        (when (eq? v %uniq)
-          (scm-error 'configuration-error
-                     "get-config"
-                     (_ "No configuration item named ~s")
-                     (list key) #f))
-        v)
-      (hashq-ref config-values key default)))
+(define (fix-keywords args)
+  (map (lambda (arg)
+         (if (keyword? (syntax->datum arg))
+             (syntax->datum arg)
+             arg))
+       args))
+
+(define %configuration-error
+  (_ "Pre-property failed when setting ~s to ~s"))
+
+(define-syntax (define-config stx)
+  (syntax-case stx ()
+    ((_ name default kw ...)
+     (let ((pre  (cond ((memv pre:  (fix-keywords #'(kw ...))) => cadr) (else #f)))
+           (post (cond ((memv post: (fix-keywords #'(kw ...))) => cadr) (else #f))))
+       #`(begin
+           (define-once name
+            (make-parameter
+             default
+             #,@(cond ((and pre post)
+                       #`((lambda (new-value)
+                            (cond ((#,pre new-value)
+                                   => (lambda (translated)
+                                        (#,post translated)
+                                        translated))
+                                  (else
+                                   (scm-error 'configuration-error
+                                              "set-config!"
+                                              %configuration-error
+                                              (list (quote name) new-value)))))))
+                      (pre
+                       #`((lambda (new-value)
+                            (or (#,pre new-value)
+                                (scm-error 'configuration-error
+                                           "set-config!"
+                                           %configuration-error
+                                           (list (quote name) new-value))))))
+                      (post
+                       #`((lambda (new-value)
+                            (#,post new-value)
+                            new-value))
+                       )
+                      (else #'()))))
+           (export name))))))
 
 
 
 (define-public ((ensure predicate) value)
   (if (predicate value)
       value #f))
-
-
-
-;; (format-procedure (lambda (x y) ...)) => λx, y
-;; (define (f x) ...)
-;; (format-procedure f) => f(x)
-(define (format-procedure proc)
-  ((aif (procedure-name proc)
-        (lambda (s) (string-append (symbol->string it) "(" s ")"))
-        (lambda (s) (string-append "λ" s)))
-   (let ((args ((@ (ice-9 session) procedure-arguments)
-                proc)))
-     (string-join
-      (remove null?
-              (list
-               (awhen ((ensure (negate null?))
-                       (assoc-ref args 'required))
-                      (format #f "~{~a~^, ~}" it))
-               (awhen ((ensure (negate null?))
-                       (assoc-ref args 'optional))
-                      (format #f "[~{~a~^, ~}]" it))
-               (awhen ((ensure (negate null?))
-                       (assoc-ref args 'keyword))
-                      (format #f "key: ~{~a~^, ~}"
-                              (map keyword->symbol
-                                   (map car it))))
-               (awhen ((ensure (negate null?))
-                       (assoc-ref args 'rest))
-                      (format #f "~a ..." it))))
-      ", "))))
-
-(export format-procedure)
-
-;; TODO break this up into separate `get-all-configuration-items' and
-;; `format-configuration-items' procedures
-(define-public (get-configuration-documentation)
-  (define groups
-    (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 ,(aif module
-                                         (->str (module-name it))
-                                         #f)))
-               ,@(concatenate
-                  (for (key value) in values
-                       `((dt ,key)
-                         (dd (p (@ (inline))
-                                ,(or (description key) "")))
-                         ;; Configuration variable value indicator
-                         (dt ,(_ "V:"))
-                         (dd ,(if (procedure? value)
-                                  (format-procedure value)
-                                  `(scheme ,value))
-                             (br)))))))))))
-
diff --git a/module/calp/util/exceptions.scm b/module/calp/util/exceptions.scm
index 0588840e..5d6a71e8 100644
--- a/module/calp/util/exceptions.scm
+++ b/module/calp/util/exceptions.scm
@@ -5,4 +5,5 @@
 
 (define-config warnings-are-errors #f
   description: (_ "Crash on warnings.")
-  post: warnings-are-errors)
+  post: (@ (hnh util exceptions) warnings-are-errors)
+  )
diff --git a/module/datetime.scm b/module/datetime.scm
index 478fc479..adff669a 100644
--- a/module/datetime.scm
+++ b/module/datetime.scm
@@ -48,11 +48,10 @@
 
 ;;; Configuration
 
-(define-public week-start (make-parameter sun))
+;; (define-public week-start (make-parameter sun))
 (define-config week-start sun
   description: "First day of week"
-  pre: (ensure (lambda (x) (<= sun x sat)))
-  post: week-start)
+  pre: (ensure (lambda (x) (<= sun x sat))))
 
 
 ;;; RECORD TYPES
diff --git a/module/datetime/instance.scm b/module/datetime/instance.scm
index 2b060204..d9a304b2 100644
--- a/module/datetime/instance.scm
+++ b/module/datetime/instance.scm
@@ -23,7 +23,7 @@
     (label self
            (case-lambda
              (()
-              (define tz-list (get-config 'tz-list))
+              (define tz-list (tz-list))
               (if (null? tz-list)
                 (warning (_ "Default zoneinfo only available when tz-dir and tz-list are configured"))
                 (self tz-list)))
diff --git a/module/vcomponent.scm b/module/vcomponent.scm
index 7618084c..0f000ba5 100644
--- a/module/vcomponent.scm
+++ b/module/vcomponent.scm
@@ -1,26 +1,17 @@
 (define-module (vcomponent)
   :use-module (hnh util)
-  :use-module (calp util config)
   :use-module (vcomponent base)
+  :use-module (vcomponent config)
   ;; :use-module ((vcomponent util instance methods)
   ;;              :select (make-vcomponent))
   :use-module ((vcomponent util parse-cal-path)
                :select (parse-cal-path))
-  :re-export (make-vcomponent parse-cal-path))
+  :re-export (make-vcomponent
+              parse-cal-path
+              ;; configuration items
+              calendar-files default-calendar))
 
 (define cm (module-public-interface (current-module)))
 (module-use! cm (resolve-interface '(vcomponent base)))
 (module-use! cm (resolve-interface '(vcomponent util instance methods)))
 
-
-(define-config calendar-files '()
-  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)]
-               [else #f])))
-
-(define-config default-calendar ""
-  description: "Default calendar to use for operations. Set to empty string to unset"
-  pre: (ensure string?))
-
diff --git a/module/vcomponent/config.scm b/module/vcomponent/config.scm
new file mode 100644
index 00000000..b2598207
--- /dev/null
+++ b/module/vcomponent/config.scm
@@ -0,0 +1,16 @@
+(define-module (vcomponent config)
+  :use-module (hnh util)
+  :use-module (calp translation)
+  :use-module (calp util config))
+
+(define-config calendar-files '()
+  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)]
+               [else #f])))
+
+(define-config default-calendar ""
+  description: (_ "Default calendar to use for operations. Set to empty string to unset")
+  pre: (ensure string?))
+
diff --git a/module/vcomponent/datetime/output.scm b/module/vcomponent/datetime/output.scm
index fe909ebb..8cb55782 100644
--- a/module/vcomponent/datetime/output.scm
+++ b/module/vcomponent/datetime/output.scm
@@ -4,6 +4,7 @@
   :use-module (vcomponent base)
   :use-module (text util)
   :use-module (calp translation)
+  :use-module ((hnh util exceptions) :select (warning))
   :use-module ((vcomponent recurrence display) :select (format-recurrence-rule))
   )
 
@@ -38,11 +39,12 @@
     "."))
 
 (define-public (format-summary ev str)
-  ((get-config 'summary-filter) ev str))
+  ((@ (calp html filter) summary-filter) ev str))
 
 ;; NOTE this should have information about context (html/term/...)
 (define-public (format-description ev str)
-  (catch #t (lambda () ((get-config 'description-filter) ev str))
+  (catch #t (lambda () ((@ (calp html filter) description-filter)
+                   ev str))
     (lambda (err . args)
       ;; Warning message for failure to format description.
       ;; First argument is name of warning/error,
diff --git a/module/vcomponent/util/instance.scm b/module/vcomponent/util/instance.scm
index d17b672a..038c6505 100644
--- a/module/vcomponent/util/instance.scm
+++ b/module/vcomponent/util/instance.scm
@@ -1,6 +1,5 @@
 (define-module (vcomponent util instance)
   :use-module (hnh util)
-  :use-module ((calp util config) :select (get-config))
   :use-module ((oop goops) :select (make))
   :use-module (calp translation)
   :export (global-event-object)
@@ -14,10 +13,10 @@
 ;; evaluate this to early.
 (define-once global-event-object
   (make (@@ (vcomponent util instance methods) <events>)
-    calendar-files: (get-config 'calendar-files)))
+    calendar-files: ((@ (vcomponent config) calendar-files))))
 
 (define-public (reload)
   (let ((new-value (make (@@ (vcomponent util instance methods) <events>)
-                     calendar-files: (get-config 'calendar-files))))
+                     calendar-files: ((@ (vcomponent config) calendar-files)))))
     (format (current-error-port) (_ "Reload done~%"))
     (set! global-event-object new-value)))