Move stuff from calp/util to hnh/util.

This is the first (major) step in splitting the generally useful items
into its own library.

1 files changed, 45 insertions, 0 deletions

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