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').

1 files changed, 44 insertions, 129 deletions

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)))))))))))
-