summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorPaul A. Patience <paul@apatience.com>2022-02-12 17:23:29 +0000
committerKaz Kylheku <kaz@kylheku.com>2022-02-12 14:17:57 -0800
commit5d8d717002db847a3630d51b6673c92b9ccd9991 (patch)
tree81e9577cc3520f24e7aa9735cce0194a8013cfa4
parent4c8608fd5cadc38c35a2b232b50b0d92da53f3bf (diff)
downloadtxr-5d8d717002db847a3630d51b6673c92b9ccd9991.tar.gz
txr-5d8d717002db847a3630d51b6673c92b9ccd9991.tar.bz2
txr-5d8d717002db847a3630d51b6673c92b9ccd9991.zip
WIP getopts: allow specifying arg names in help.
* stdlib/getopts.tl (basic-type-p): Handle the cons case. (sys:opt-parsed convert-type): Same. (opthelp): Same. (opthelp-types): Same, and for each type in the legend, specify which arguments correspond to it.
-rw-r--r--stdlib/getopts.tl33
1 files changed, 27 insertions, 6 deletions
diff --git a/stdlib/getopts.tl b/stdlib/getopts.tl
index 8e098455..fb1ee007 100644
--- a/stdlib/getopts.tl
+++ b/stdlib/getopts.tl
@@ -68,7 +68,11 @@
`@(if (> (length name) 1) "-")-@name`)
(defmeth opt-desc basic-type-p (me type)
- (or (functionp type) (fboundp type) (member type me.valid-types)))
+ (tree-case type
+ ((type name) (and (neq type :bool)
+ me.(basic-type-p type)
+ (stringp name)))
+ (type (or (functionp type) (fboundp type) (member type me.valid-types)))))
(defmeth opt-desc list-type-p (me type)
(tree-case type
@@ -108,7 +112,7 @@
(when (and (neq type :bool)
(eq me.arg :explicit-no))
(sys:opt-err "Non-Boolean option ~a explicitly specified as false" name))
- (caseql type
+ (caseql [[iffi [andf consp [chain car keywordp]] car] type]
(:bool
(set me.arg (neq me.arg :explicit-no)))
(:dec (set me.arg
@@ -285,10 +289,13 @@
od.type))
(tstr (cond
((keywordp type) (upcase-str (symbol-name type)))
- ((and (consp type) (eq (car type) 'list))
- (let ((ts (upcase-str (symbol-name (cadr type)))))
+ ((not (consp type)) "ARG")
+ ((eq (car type) 'list)
+ (let ((ts (ifa (consp (cadr type))
+ (cadr it)
+ (upcase-str (symbol-name it)))))
`@ts[,@ts...]`))
- (t "ARG")))
+ (t (cadr type))))
(long (if od.long
`--@{od.long}@(if od.arg-p `=@tstr`)`))
(short (if od.short
@@ -372,6 +379,7 @@
(ldo match-ecase
((@(or list cumul) @type)
@(rec type))
+ ((@type @nil) type)
(@type type)))
documented))))
(entries (isec
@@ -390,7 +398,20 @@
(:text " TEXT - Unprocessed text"))
types : [iffi consp car])))
(put-line "Type legend:\n")
- (mapdo (opip cadr put-line) entries)
+ (mapdo (tb ((btype legend))
+ ;; TODO Make coherent the punctuation?
+ (put-line legend)
+ (whenlet ((names (uniq (mappend (chain (usl type)
+ (ldo match-case
+ ((@(or list cumul) @type)
+ @(rec type))
+ ((@btype @name)
+ (list name))))
+ documented))))
+ (mapdo (do put-line `@{"" 10}@1`)
+ (sys:wdwrap `Arguments of this type:\
+ \ @(cat-str names #\ )` 69))))
+ entries)
(put-line)))
(defstruct sys:option-base nil