Fix configuration help, print with --help.

2 files changed, 62 insertions, 17 deletions

diff --git a/module/main.scm b/module/main.scm
index 7119278e..97657e1c 100644
--- a/module/main.scm
+++ b/module/main.scm
@@ -37,17 +37,16 @@
 
 (define options
   '((statprof (value display-style)
-              (description (*TOP* "Run the program within Guile's built in statical"
+              (description (*TOP* "Run the program within Guile's built in statical "
                                   "profiler. Display style is one of "
-                                  (b "flat") " and " (b "tree") ".")))
+                                  (b "flat") " or " (b "tree") ".")))
     (repl (value address)
           (description
            (*TOP* "Start a Guile repl which can be connected to, defaults to the unix socket "
                   (i "/run/user/${UID}/calp-${PID}") ", but it can be bound to any unix or "
                   "TCP socket. ((@ (util app) current-app)) should return the current app context."
                   (br)
-                  (b "Should NOT be used in production.")))
-          )
+                  (b "Should NOT be used in production."))))
     (help (single-char #\h)
           (description "Print this help"))))
 
@@ -92,13 +91,6 @@
   (define stprof (option-ref opts 'statprof #f))
   (define repl (option-ref opts 'repl #f))
 
-  (awhen (option-ref opts 'help #f)
-         (display (sxml->ansi-text module-help)
-                  (current-output-port))
-         (print-arg-help options)
-         (throw 'return)
-         )
-
   (when stprof (statprof-start))
 
   (cond [(eqv? #t repl) (repl-start (format #f "~a/calp-~a" (runtime-dir) (getpid)))]
@@ -110,6 +102,16 @@
      (primitive-load config-file)))
 
 
+  ;; help printing moved below some other stuff to allow
+  ;; print-configuration-and-return to show bound values.
+  (awhen (option-ref opts 'help #f)
+         (display (sxml->ansi-text module-help)
+                  (current-output-port))
+         (print-arg-help options)
+         (display (sxml->ansi-text (get-configuration-documentation))
+                  (current-output-port))
+         (throw 'return)
+         )
   ;; (current-app (make-app))
 
   ((@ (vcomponent) init-app) (get-config 'calendar-files))
diff --git a/module/util/config.scm b/module/util/config.scm
index 6d2d9ab8..a5d29f8e 100644
--- a/module/util/config.scm
+++ b/module/util/config.scm
@@ -114,15 +114,58 @@
         (get-value v)
         v)))
 
-
-(define-public (print-configuration-documentation)
+;; (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)
+
+(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 )) )
-  (for (module values) in groups
-       (format #t "~%~a~%" (module-name module))
-       (for (key value) in values
-            (format #t "  ~20,a | ~a~%" key (get-documentation value)))))
+
+
+  `(*TOP*
+    (header "Configuration variables")
+    (dl
+     ,@(concatenate
+        (for (module values) in groups
+             `((dt "") (dd (header ,(format #f "~a" (module-name module))))
+               ,@(concatenate
+                  (for (key value) in values
+                       `((dt ,key)
+                         (dd (p (@ (inline)) ,(get-documentation value)))
+                         (dt "V:")
+                         (dd ,(let ((v (get-value value)))
+                                (if (procedure? v)
+                                    (format-procedure v)
+                                    `(scheme ,v)))
+                             (br)))))))))))