;; cli.lisp -- Command line interface entry point and 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/cli)

(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."))

(defun eval-and-typeset-propositions (prop-strs &key (format "unicode")
                                                  (implicit-and t)
                                                  multi-char-names
                                                  include-intermediate
                                                  (include-vars t))
  "Evaluate and then typeset PROP-STRS as a table, which is a list of
proposition strings. For a description of the key parameters, see each of the
functions involved in evaluating and typesetting."
  (loop with vars = '()
        for prop-str in prop-strs
        for (parsed-exp parsed-vars)
          = (multiple-value-list
             (parse-proposition-string prop-str
                                       :implicit-and implicit-and
                                       :multi-char-names multi-char-names))
        collect parsed-exp into exps
        do (dolist (var parsed-vars)
             (unless (member var vars :test 'equal)
               (setq vars (nconc vars (list var)))))
        finally
           (let ((table (create-combined-truth-table
                         exps vars
                         :include-intermediate include-intermediate
                         :include-vars include-vars)))
             (return (typeset-table-to-format table format)))))

(defparameter *command-line-spec*
  '((#\h "help" help nil "print this message, then exit")
    (#\f "format" format t "specify the output format (*unicode*, ascii, or latex)")
    (#\s "subexps" subexps nil "include sub-expressions in the output table")
    (#\n "no-vars" no-vars nil "do not include variables in the output table")
    (#\m "multi-char" multi-char nil "allow multi-character variable names")
    (#\i "no-implicit" no-implicit nil "do not use implicit 'and' operations"))
  "Specification for `parse-command-line'. This is of the format:
(short long symbol has-arg-p desc).")

(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)
  "Print the command line usage corresponding to SPEC to STREAM."
  (format stream "usage: truth-table [options] <propositions...>~%~%")
  (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 (or 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.~%"))

(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)))

(defun main (argv)
  "The main entry point to the program. ARGV is the list of command line
arguments."
  (let ((cmdline-error nil))
    (handler-bind
        (((or proposition-parse-error proposition-eval-error
              table-format-error)
           (lambda (c)
             (format *error-output* "error: ~a~%" c)
             (uiop:quit 1)))
         (command-line-error
           (lambda (c) ;; finish parsing command line before exiting
             (format *error-output* "error: ~a~%" c)
             (setq cmdline-error t)
             (continue))))
      (destructuring-bind ((&rest prop-strs) &rest opts)
          (parse-command-line *command-line-spec* argv)
        (cond
          ((option-value 'help opts)
           (print-usage t *command-line-spec*)
           (uiop:quit (if cmdline-error 1 0)))
          ((null prop-strs)
           (cerror *cli-parse-continue-string* 'no-input-error))
          (cmdline-error
           (format *error-output* "Try -h or --help for more information.~%")
           (uiop:quit 1))
          (t
           (let ((format (option-value 'format opts)))
             (when (or (not format) (zerop (length format)))
               (setq format "unicode"))
             (princ (eval-and-typeset-propositions
                     prop-strs :format format
                               :implicit-and (not (option-value 'no-implicit opts))
                               :multi-char-names (option-value 'multi-char opts)
                               :include-vars (not (option-value 'no-vars opts))
                               :include-intermediate (option-value 'subexps opts)))
             (terpri))))))))

(defun toplevel ()
  "Top-level function to be passed to `save-lisp-and-die'."
  (handler-case
      (with-user-abort:with-user-abort
        (main (uiop:command-line-arguments)))
    (with-user-abort:user-abort ()
      (format *error-output* "Keyboard interrupt~%")
      (uiop:quit 1))))