From 807409d41f8b1a4435ee1cf7ddc3d1a1b9116799 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Mon, 31 Jan 2022 20:24:18 +0100 Subject: Move stuff from calp/util to hnh/util. This is the first (major) step in splitting the generally useful items into its own library. --- module/hnh/util/options.scm | 45 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 45 insertions(+) create mode 100644 module/hnh/util/options.scm (limited to 'module/hnh/util/options.scm') diff --git a/module/hnh/util/options.scm b/module/hnh/util/options.scm new file mode 100644 index 00000000..57473816 --- /dev/null +++ b/module/hnh/util/options.scm @@ -0,0 +1,45 @@ +(define-module (hnh util options) + :use-module (hnh util) + :use-module (ice-9 match) + :use-module (srfi srfi-1) + :use-module (text markup) + ) + +;; option-assoc → getopt-valid option-assoc +(define-public (getopt-opt options) + (define ice-9-names '(single-char required? value predicate)) + (for (option-name flags ...) in options + (cons option-name + (map (match-lambda + (('value (_ ...)) `(value #t)) + (('value (? symbol? _)) `(value optional)) + ((key v) `(,key ,v))) + (filter (match-lambda ((key _ ...) (memv key ice-9-names))) + flags))))) + + +;; (name (key value) ...) → sxml +(define (fmt-help option-line) + (match option-line + ((name args ...) + (let ((valuefmt (match (assoc-ref args 'value) + [(#t) '(" " (i value))] + [(or #f (#f)) '()] + [(('options options ...)) + `(" {" ,(string-join options "|") "}")] + [(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)))))))) + +(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