diff options
Diffstat (limited to 'module')
-rw-r--r-- | module/main.scm | 24 | ||||
-rw-r--r-- | module/util/config.scm | 55 |
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))))))))))) |