diff options
Diffstat (limited to 'stdlib/getopts.tl')
| -rw-r--r-- | stdlib/getopts.tl | 407 |
1 files changed, 407 insertions, 0 deletions
diff --git a/stdlib/getopts.tl b/stdlib/getopts.tl new file mode 100644 index 00000000..99ce9f9b --- /dev/null +++ b/stdlib/getopts.tl @@ -0,0 +1,407 @@ +;; Copyright 2016-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are met: +;; +;; 1. Redistributions of source code must retain the above copyright notice, this +;; list of conditions and the following disclaimer. +;; +;; 2. Redistributions in binary form must reproduce the above copyright notice, +;; this list of conditions and the following disclaimer in the documentation +;; and/or other materials provided with the distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(defex opt-error error) + +(defstruct opt-desc nil + short + long + helptext + arg-p + (type :bool) + (:static valid-types '(:bool :dec :hex :oct :cint :float :str :text)) + (:postinit (me) + me.(check) + (set me.arg-p (neq me.type :bool)))) + +(defstruct (sys:opt-parsed name arg desc : eff-type) nil + name + arg ;; string, integer, real, ... + desc ;; opt-desc + eff-type + cumul + (:postinit (me) me.(convert-type))) + +(defstruct opts nil + (opt-hash (hash :equal-based)) ;; string to sys:opt-parsed + in-args + out-args) + +(defstruct sys:opt-processor nil + od-list + (od-hash (hash :equal-based)) ;; string to opt-desc + opts + (:postinit (me) + me.(build-hash))) + +(defun sys:opt-err (. args) + (throwf 'opt-error . args)) + +(defun getopts-error (msg . args) + (error `~s: @msg` 'getopts . args)) + +(defun sys:opt-dash (name) + `@(if (> (length name) 1) "-")-@name`) + +(defmeth opt-desc basic-type-p (me type) + (or (functionp type) (fboundp type) (member type me.valid-types))) + +(defmeth opt-desc list-type-p (me type) + (tree-case type + ((indicator btype) (and (eq indicator 'list) + me.(basic-type-p btype))) + (x nil))) + +(defmeth opt-desc cumul-type-p (me type) + (tree-case type + ((indicator btype) (and (eq indicator 'usr:cumul) + (or me.(basic-type-p btype) + me.(list-type-p btype)))) + (x nil))) + +(defmeth opt-desc check (me) + (unless (or me.(basic-type-p me.type) + me.(list-type-p me.type) + me.(cumul-type-p me.type)) + (getopts-error "invalid option type specifier ~s" + me.type)) + (when me.long + (when (< (length me.long) 2) + (getopts-error "long option ~a has a short name" me.long)) + (when (eql [me.long 0] #\-) + (getopts-error "long option ~a starts with - character" me.long))) + (when me.short + (when (neq (length me.short) 1) + (getopts-error "short option ~a not one character long" me.short)) + (when (eql [me.short 0] #\-) + (getopts-error "short option ~a starts with - character" me.short)))) + +(defmeth sys:opt-parsed convert-type (me) + (let ((name (sys:opt-dash me.name)) + (type (or me.eff-type me.desc.type))) + (when (and (neq type :bool) + (eq me.arg :explicit-no)) + (sys:opt-err "Non-Boolean option ~a explicitly specified as false" name)) + (caseql type + (:bool + (set me.arg (neq me.arg :explicit-no))) + (:dec (set me.arg + (or (and (r^$ #/[+\-]?\d+/ me.arg) (int-str me.arg)) + (sys:opt-err "option ~a needs decimal integer arg, not ~a" + name me.arg)))) + (:hex (set me.arg + (or (and (r^$ #/[+\-]?[\da-fA-F]+/ me.arg) (int-str me.arg 16)) + (sys:opt-err "option ~a needs hexadecimal integer arg, not ~a" + name me.arg)))) + (:oct (set me.arg + (or (and (r^$ #/[+\-]?[0-7]+/ me.arg) (int-str me.arg 8)) + (sys:opt-err "option ~a needs octal integer arg, not ~a" + name me.arg)))) + (:cint (set me.arg + (cond + ((r^$ #/[+\-]?0x[\da-fA-F]+/ me.arg) + (int-str (regsub #/0x/ "" me.arg) 16)) + ((r^$ #/[+\-]?0[0-7]+/ me.arg) + (int-str me.arg 8)) + ((r^$ #/[+\-]?0[\da-fA-F]+/ me.arg) + (sys:opt-err "option ~a argument ~a non octal, but leading 0" + name me.arg)) + ((r^$ #/[+\-]?\d+/ me.arg) + (int-str me.arg)) + (t (sys:opt-err "option ~a needs C style numeric arg, not ~a" + name me.arg))))) + (:float (set me.arg + (cond + ([[chand (orf (f^$ #/[+\-]?\d+[.]?([Ee][+\-]?\d+)?/) + (f^$ #/[+\-]?\d*[.]?\d+([Ee][+\-]?\d+)?/)) + flo-str] me.arg]) + (t (sys:opt-err "option ~a needs floating-point arg, not ~a" + name me.arg))))) + (:str (set me.arg + (or (ignerr (read `"@{me.arg}"`)) + (sys:opt-err "option ~a needs string lit syntax, ~a given" + name me.arg)))) + (:text) + (t (cond + ((and (consp type) (eq (car type) 'list)) + (let* ((rec-type (cadr type)) + (pieces (split-str me.arg #/,/)) + (sub-opts (mapcar (do new (sys:opt-parsed me.name @1 + me.desc + rec-type)) + pieces))) + (set me.arg (mapcar (usl arg) sub-opts)))) + ((and (consp type) (eq (car type) 'cumul)) + (let* ((rec-type (cadr type)) + (sub-opt (new (sys:opt-parsed me.name me.arg + me.desc rec-type)))) + (set me.arg sub-opt.arg + me.cumul t))) + ((or (symbolp type) (functionp type)) + (set me.arg (call type me.arg)))))))) + +(defmeth opts lambda (me key : dfl) + (iflet ((o [me.opt-hash key])) o.arg dfl)) + +(defmeth opts lambda-set (me key val) + (iflet ((o [me.opt-hash key])) + (set o.arg val) + (error "opts: cannot set option ~s to ~s: no such option" key val))) + +(defmeth opts add-opt (me opt) + (when opt.cumul + (let* ((old-opt [me.opt-hash (or opt.desc.long + opt.desc.short)]) + (old-arg (if old-opt old-opt.arg))) + (set opt.arg (cons opt.arg old-arg)))) + (whenlet ((n opt.desc.short)) + (set [me.opt-hash n] opt)) + (whenlet ((n opt.desc.long)) + (set [me.opt-hash n] opt))) + +(defmeth sys:opt-processor build-hash (me) + (each ((od me.od-list)) + (unless (or od.long od.short) + (error "opt-processor: no short or long name in option ~s" od)) + (each ((str (list od.long od.short))) + (when (and str [me.od-hash str]) + (error "opt-processor: duplicate option ~s" str)) + (set [me.od-hash str] od)))) + +(defmeth sys:opt-processor parse-long (me opt : arg) + (iflet ((ieq (unless (stringp arg) (break-str opt "=")))) + (let ((oname [opt 0..ieq]) + (arg [opt (succ ieq)..:])) + me.(parse-long oname arg)) + (let ((od [me.od-hash opt]) + (opts me.opts)) + (cond + ((null od) + (sys:opt-err "unrecognized option: --~a" opt)) + ((and arg od.arg-p) + opts.(add-opt (new (sys:opt-parsed opt arg od)))) + ((stringp arg) + (sys:opt-err "option --~a doesn't take an argument" opt)) + (od.arg-p + (iflet ((arg (pop opts.out-args))) + opts.(add-opt (new (sys:opt-parsed opt arg od))) + (sys:opt-err "option --~a requires an argument" opt))) + (t opts.(add-opt (new (sys:opt-parsed opt arg od)))))))) + +(defmeth sys:opt-processor parse-shorts (me oarg) + (each ((o (split-str oarg #//))) + (iflet ((opts me.opts) + (od [me.od-hash o])) + (let ((arg (when od.arg-p + (when (> (length oarg) 1) + (sys:opt-err "argument -~a includes -~a, which does not clump" + oarg o)) + (unless opts.out-args + (sys:opt-err "option -~a requires an argument" o)) + (pop opts.out-args)))) + opts.(add-opt (new (sys:opt-parsed o arg od)))) + (sys:opt-err "unrecognized option: -~a" o)))) + +(defmeth sys:opt-processor parse-opts (me args) + (let ((opts me.opts)) + (whilet ((arg (pop opts.out-args))) + (cond + ((equal "--" arg) (return)) + ((r^ #/--no-/ arg) me.(parse-long [arg 5..:] :explicit-no)) + ((r^ #/--/ arg) me.(parse-long [arg 2..:])) + ((r^ #/-.+/ arg) me.(parse-shorts [arg 1..:])) + (t (push arg opts.out-args) + (return)))) + opts)) + +(defun sys:wdwrap (string columns) + (let ((words (tok-str string #/\S+/)) + line) + (build + (whilet ((word (pop words)) + (wpart (cond + ((and word (r^$ #/\w+[\w\-]*\w[.,;:!?"]?/ word)) + (split-str word #/-/)) + (word (list word)))) + (wpart-orig wpart)) + (whilet ((wp0 (eq wpart wpart-orig)) + (wp (pop wpart)) + (w (if wp `@wp@(if wpart "-")`))) + (cond + ((not line) + (set line w)) + ((> (+ (length line) (length w) 1) columns) + (add line) + (set line w)) + (t (set line `@line@(if wp0 " ")@w`))))) + (if line + (add line))))) + +(defun opt (short long : (type :bool) helptext) + (new opt-desc short short long long helptext helptext type type)) + +(defun getopts (opt-desc-list args) + (let* ((opts (new opts in-args args out-args args)) + (opr (new sys:opt-processor od-list opt-desc-list opts opts))) + opr.(parse-opts args))) + +(defun opthelp (opt-desc-list : (stream *stdout*)) + (let ((sorted [nsort (copy-list (remove-if (op null @1.helptext) + opt-desc-list)) : + (do if @1.long @1.long @1.short)]) + (undocumented (keep-if (op null @1.helptext) opt-desc-list))) + (put-line "\nOptions:\n") + (each ((od sorted)) + (let* ((type (if (and (consp od.type) (eq (car od.type) 'cumul)) + (cadr od.type) + 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))))) + `@ts[,@ts...]`)) + (t "ARG"))) + (long (if od.long + `--@{od.long}@(if od.arg-p `=@tstr`)`)) + (short (if od.short + `-@{od.short}@(if od.arg-p ` @tstr`)`)) + (ls (cond + ((and long short) `@{long 21} (@short)`) + (long long) + (short `@{"" 21} @short`))) + (lines (if od.helptext (sys:wdwrap od.helptext 43)))) + (put-line ` @{ls 34}@(pop lines)`) + (while lines + (put-line ` @{"" 34}@(pop lines)`)))) + (put-line) + (when undocumented + (put-line "Undocumented options:\n") + (let* ((undoc-str `@{[mapcar sys:opt-dash + (flatten (mappend (op list @1.short @1.long) + undocumented))] ", "}`)) + (each ((line (sys:wdwrap undoc-str 75))) + (put-line ` @line`))) + (put-line)) + (put-line "Notes:\n") + (let* ((have-short (some sorted (usl short))) + (have-long (some sorted (usl long))) + (have-arg-p (some sorted (usl arg-p))) + (have-bool (some sorted (op eq @1.type :bool))) + (texts (list (if have-short + "Short options can be invoked with long syntax: \ \ + for example, --a can be used when -a exists.\ \ + Short no-argument options can be clumped into\ \ + one argument as exemplified by -xyz.") + (if have-bool + (if have-arg-p + "Options that take no argument are Boolean:" + (if undocumented + "All documented options are Boolean:" + "All options are Boolean:"))) + (if have-bool + "they are true when present, false when absent.") + (if (and have-bool have-arg-p) + "The --no- prefix can explicitly specify \ \ + Boolean options as false: if a Boolean option\ \ + X exists,\ \ + --no-X specifies it as false. This is useful\ \ + for making false those options which default\ \ + to true. " + "The --no- prefix can explicitly specify \ \ + options as false: if an X option exists,\ \ + --no-X specifies it as false. This is useful\ \ + for making false those options which default\ \ + to true. ") + (if (not have-long) + "Note the double dash on --no.") + (if (and have-short have-long) + "The --no- prefix can be applied to a short\ \ + or long option name.") + (if have-arg-p + "The argument to a long option can be given in one\ \ + argument as --option=arg or as a separate\ \ + argument using --option arg.") + "The special argument -- can be used where an option\ \ + may appear. It means \"end of options\": the\ \ + arguments which follow are not treated as options\ \ + even if they look like options."))) + (mapdo (do put-line ` @1`) + (sys:wdwrap `@{(flatten texts)}` 77))) + (put-line) + (whenlet ((types (keep-if [andf keywordp (op neq :bool)] + (uniq (mapcar (usl type) sorted))))) + (put-line "Type legend:\n") + (each ((ty types)) + (iflet ((ln (caseql ty + (:dec " DEC - Decimal integer: -123, 0, 5, +73") + (:hex " HEX - Hexadecimal integer -EF, 2D0, +9A") + (:oct " OCT - Octal integer: -773, 5677, +326") + (:cint " CINT - C-style integer: leading 0 octal,\ + \ leading 0x hex, else decimal;\n\ + \ leading sign allowed: -0777, 0xFDC, +123") + (:float " FLOAT - Floating-point: -1.3e+03, +5, 3.3,\ + \ 3., .5, .12e9, 53.e-3, 3e-015") + (:str " STR - String with embedded escapes, valid\ + \ as TXR Lisp string literals\n\ + \ syntax: foo, foo\\tbar, abc\\nxyz") + (:text " TEXT - Unprocessed text")))) + (put-line ln))) + (put-line)))) + + +(defstruct sys:option-base nil + in-args + out-args + (:static slot-hash) + (:static opt-desc-list) + (:method add-opt (me opt) + (let* ((sl [me.slot-hash (or opt.desc.long opt.desc.short)]) + (arg (if opt.cumul + (cons opt.arg (slot me sl)) + opt.arg))) + (slotset me sl arg))) + (:method getopts (me args) + (set me.in-args args me.out-args args) + (let ((opr (new sys:opt-processor od-list me.opt-desc-list opts me))) + opr.(parse-opts args))) + (:method opthelp (me : (stream *stdout*)) + (opthelp me.opt-desc-list stream))) + +(defmacro define-option-struct (name super-spec . opts) + (let* ((slots (mapcar (tb ((short long . rest)) + (or long short)) + opts)) + (supers (if (and super-spec (atom super-spec)) + (list super-spec) + super-spec))) + ^(defstruct ,name (,*supers sys:option-base) + ,*slots + (:static slot-hash #H(() ,*(mapcar [juxt symbol-name identity] slots))) + (:static opt-desc-list ',(mapcar (tb ((short long . rest)) + (opt (if short (symbol-name short)) + (if long (symbol-name long)) + . rest)) + opts))))) |