1 files changed, 48 insertions, 0 deletions
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))