truth-table/arguments.lisp

;; arguments.lisp -- Command line option parsing
;; Copyright (C) 2024  Alexander Rosenberg
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
(in-package :truth-table/args)

(define-condition command-line-error (error)
  ((message :initarg :message
            :accessor command-line-error-message))
  (:report (lambda (con stream)
             (format stream "~a"
                     (command-line-error-message con))))
  (:documentation "The parent condition of all command line errors."))

(define-condition cli-argument-error (command-line-error)
  ((opt :initarg :opt
        :accessor cli-argument-error-opt))
  (:report (lambda (con stream)
             (with-slots (opt message) con
               (format stream
                       "~a: ~:[--~a~;-~c~]" message (characterp opt) opt))))
  (:documentation "Condition representing an error that occurred during
processing of command line arguments."))

(define-condition unknown-option-error (cli-argument-error)
  ((message :initform "unknown option"))
  (:documentation "Condition representing an unknown command line option."))

(define-condition option-no-arg-error (cli-argument-error)
  ((message :initform "option requires an argument"))
  (:documentation "Condition representing an error that occurred because a
command line option did not have its required argument."))

(define-condition no-input-error (command-line-error)
  ((message :initform "no propositions given"))
  (:documentation "Condition representing no propositions given on the command
line."))

(defparameter *cli-parse-continue-string*
  "Continue paring arguments normally."
  "String to use for `cerror' during argument parsing.")

(defun parse-long-option (spec arg next-arg)
  "Parse the long option ARG. Return a list of its symbol, its value (or t if
it did not have one), and weather it consumed NEXT-ARG or not."
  (destructuring-bind (name &optional value)
      (uiop:split-string (subseq arg 2)
                         :max 2
                         :separator "=")
    (loop for (short long symbol has-arg-p dest) in spec
          when (equal name long) do
            (if has-arg-p
                (cond
                  (value
                   (return (list symbol value nil)))
                  (next-arg
                   (return (list symbol next-arg t)))
                  (t
                   (cerror *cli-parse-continue-string*
                           'option-no-arg-error :opt name)
                   (return (list symbol nil nil))))
                (return (list symbol t nil)))
          finally
             (cerror *cli-parse-continue-string*
                     'unknown-option-error :opt name)
             (return (list symbol nil nil)))))

(defun parse-short-option (spec arg next-arg)
  "Parse the short options in ARG according to SPEC. Return a list of options
with each entry being similar to the return value of `parse-long-option'."
  (loop with output = '()
        for i from 1 to (1- (length arg))
        for char = (elt arg i)
        for (short long symbol has-arg-p desc) = (assoc char spec) do
          (cond
            (has-arg-p
             (cond
               ((< i (1- (length arg)))
                (push (list symbol (subseq arg (1+ i)) nil) output)
                (return output))
               (next-arg
                (push (list symbol next-arg t) output)
                (return output))
               (t
                (cerror *cli-parse-continue-string*
                        'option-no-arg-error :opt char))))
            (short
             (push (list symbol t nil) output))
            (t
             (cerror *cli-parse-continue-string*
                     'unknown-option-error :opt char)))
        finally (return output)))

(defun parse-command-line (spec argv)
  "Parse command line arguments in ARGV according to SPEC. Return an alist with
the car being the option's symbol (as specified in SPEC), and the cdr being
the argument it had on the command line, or t if it had none. The rest of the
arguments will be placed in a list at the beginning of the alist."
  (let ((output-opts '())
        (output-other '()))
    (loop for (arg . rest) = argv then rest
        while (and arg (not (equal arg "--"))) do
          (cond
            ((uiop:string-prefix-p "--" arg)
             (destructuring-bind (symbol value skip-next-p)
                 (parse-long-option spec arg (car rest))
               (push (cons symbol value) output-opts)
               (when skip-next-p
                 (setq rest (cdr rest)))))
            ((uiop:string-prefix-p "-" arg)
             (loop for (symbol value skip-next-p) in (parse-short-option
                                                      spec arg (car rest))
                   do
                      (push (cons symbol value) output-opts)
                      (when skip-next-p
                        (setq rest (cdr rest)))))
            (t
             (push arg output-other)))
          finally (setf output-other (nconc (nreverse rest) output-other)))
    (cons (nreverse output-other) output-opts)))

(defun print-usage (stream spec exec-name &key general-args
                                            (print-astrisk t))
  "Print the command line usage corresponding to SPEC to STREAM."
  (format stream "usage: ~a [options]~@[ ~a~]~%~%" exec-name general-args)
  (loop with longest-option
          = (apply 'max (mapcar
                         (lambda (entry)
                           (destructuring-bind (short long sym has-arg-p &rest other)
                               entry
                             (declare (ignorable other sym))
                             (+ (if short 2 0)
                                (if long (+ 2 (length long)) 0)
                                (if (and short long) 2 0)
                                (if has-arg-p 6 0))))
                         spec))
        for (short long symbol has-arg-p desc) in spec
        do
           (format stream "  ~v@<~@[-~c~]~@[, ~*~]~@[--~a~]~@[=<arg>~*~]~>  ~a~%"
                   longest-option
                   short (and short long) long has-arg-p desc))
  (format stream
"~%~@[The choice surrounded by '*' is the default. ~]Arguments to long~:[ ~;~%~]~
options are also required for their short variant.~%" print-astrisk print-astrisk))

(defun option-value (opt opts)
  "Get the value of command line option OPT from OTPS, which is an alist as
returned as the second output of `parse-command-line'."
  (cdr (assoc opt opts)))