From d3afa54144748685d12c159407194e03538e98de Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Mon, 24 Aug 2020 20:34:11 +0200 Subject: Move util modules into calp module.. --- module/calp/util/options.scm | 48 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 48 insertions(+) create mode 100644 module/calp/util/options.scm (limited to 'module/calp/util/options.scm') diff --git a/module/calp/util/options.scm b/module/calp/util/options.scm new file mode 100644 index 00000000..0e239a78 --- /dev/null +++ b/module/calp/util/options.scm @@ -0,0 +1,48 @@ +(define-module (calp util options) + :use-module (calp util) + :use-module (srfi srfi-1) +) + +;; option-assoc → getopt-valid option-assoc +(define-public (getopt-opt options) + (map (lambda (optline) + (cons (car optline) + (map (lambda (opt-field) + (cons (car opt-field) + (cond [(and (eq? 'value (car opt-field)) + (symbol? (cadr opt-field))) + '(optional)] + [else (cdr opt-field)]))) + (lset-intersection (lambda (a b) (eqv? b (car a))) + (cdr optline) + '(single-char required? value predicate))))) + options)) + + + + +;; (name (key value) ...) → sxml +(define (fmt-help option-line) + (let ((name (car option-line)) + (args (cdr option-line))) + (let ((valuefmt (case (and=> (assoc-ref args 'value) car) + [(#t) '(" " (i value))] + [(#f) '()] + [else => (lambda (s) `(" [" (i ,s) "]"))]))) + `(*TOP* (b "--" ,name) ,@valuefmt + ,@(awhen (assoc-ref args 'single-char) + `("," (ws) + (b "-" ,(car it)) + ,@valuefmt)) + (br) + ,@(awhen (assoc-ref args 'description) + `((blockquote ,@it) + (br))))))) + +(use-modules (text markup)) + +(define-public (format-arg-help options) + (sxml->ansi-text (cons '*TOP* (map sxml->ansi-text (map fmt-help options))))) + +(define*-public (print-arg-help options optional: (port (current-error-port))) + (display (format-arg-help options) port)) -- cgit v1.2.3