path: root/share/txr/stdlib/getopts.tl

;; Copyright 2016-2020
;; 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)))))