;;;; PMSF-Lib --- PMSF Common Lisp Utility Library
;;;; This is copyrighted software.  See documentation for terms.
;;;; 
;;;; cmdline-utilities.lisp --- Command Line Parsing and Access
;;;; 
;;;; $Id$

(cl:in-package #:pmsf-lib)

(pmsf-lib:file-version :pmsf-lib "$Id$")

;;;; %File Description:
;;;; 
;;;; This file contains utilities to access the command line and to
;;;; parse command line arguments for options and proper arguments.
;;;; 

(defun get-command-line-arguments ()
  "Return the list of command line arguments passed to this process, including
the program name as its first argument."
  #+sbcl
  (copy-list sb-ext:*posix-argv*)
  #+lispworks
  (copy-list system:*line-arguments-list*))

;;;
;;; Parsing
;;;

(define-condition command-line-argument-error (simple-error)
  ((command-line :initarg :command-line 
                 :reader command-line-argument-error-command-line)
   (remaining-arguments :initarg :remaining-arguments 
                        :reader 
                        command-line-argument-error-remaining-arguments))
  (:report 
   (lambda (c s)
     (with-standard-io-syntax
       (let ((*print-readably* nil))
         (format s 
                 "Error parsing command-line: ~?~%~
                  For command-line ~{~S~^ ~}, remaining arguments: ~{~S~^ ~}"
                 (simple-condition-format-control c)
                 (simple-condition-format-arguments c)
                 (command-line-argument-error-command-line c)
                 (command-line-argument-error-remaining-arguments c)))))))

;;;
;;; Main Entry Point
;;;

(defun parse-command-line-arguments (command-line 
                                 &key (required-arguments 0) allowed-arguments
                                 option-specs)
  "Parse the command-line given in COMMAND-LINE for the program-name, the
normal arguments and any options, based on the specifications given through
REQUIRED-ARGUMENTS, ALLOWED-ARGUMENTS and OPTION-SPECS.  This function will
signal a COMMAND-LINE-ARGUMENT-ERROR if any of those specifications can't be
matched.  Returns three values, the name of the program as a string, the list
of normal arguments after option processing finished, and an alist of options
and their arguments, as specified by option-spec."
  (let ((program-name (first command-line))
        (arguments (rest command-line)))
    (flet ((is-long-option-p (arg)
             (when (and (>= (length arg) 2) (string= arg "--" :end1 2))
               (subseq arg 2)))
           (find-option-by-name (name)
             (find name option-specs :key #'first :test #'string=))
           (is-option-terminator-p (name)
             (string= name ""))
           (command-line-argument-error (rest control &rest args)
             (error 'command-line-argument-error
                    :command-line command-line
                    :remaining-arguments rest
                    :format-control control
                    :format-arguments args)))
      ;; Process and collect options
      (loop with options = nil
         with rest-arguments = arguments 
         for arg = (pop rest-arguments)
         for option-name = (and arg (is-long-option-p arg))
         for option = (and option-name (find-option-by-name option-name))
         while (and option-name (not (is-option-terminator-p option-name)))
         do
           (unless option
             (command-line-argument-error 
              rest-arguments
              "Unknown option ~A, known options: ~{~A~^, ~}"
              option-name (mapcar #'first option-specs)))
           (destructuring-bind (option-matcher option-key option-arguments)
               option
             (unless (>= (length rest-arguments) option-arguments)
               (command-line-argument-error 
                rest-arguments
                "Option ~A needs ~D arguments but has only ~D."
                option-matcher option-arguments (length rest-arguments)))
             (push (list* option-key
                          (subseq rest-arguments 0 option-arguments))
                   options)
             (setq rest-arguments (nthcdr option-arguments rest-arguments)))
         finally
           (when arg
             (unless (and option-name (is-option-terminator-p option-name))
               (push arg rest-arguments)))
           (unless (>= (length rest-arguments) required-arguments)
             (command-line-argument-error 
              rest-arguments
              "~A needs ~D arguments but has only ~D."
              program-name required-arguments (length rest-arguments)))
           (unless (or (null allowed-arguments)
                       (<= (length rest-arguments) allowed-arguments))
             (command-line-argument-error 
              rest-arguments
              "~A needs at most ~D arguments but has ~D."
              program-name allowed-arguments (length rest-arguments)))
           (return (values program-name rest-arguments (nreverse options)))))))

;;;
;;; Parsing for lambda lists
;;;

(defun make-options-argument-list (options)
  (loop with result = nil
     for (option . args) in options
     do
       (cond
         ((null args)
          (setf (getf result option) t))
         (t
          (push args (getf result option nil))))
     finally
       (return
         (loop for (key values) on result by #'cddr
            collect key
            collect
              (cond
                ((eq values t)
                 values)
                ((and (null (cdr values)) (null (cdar values)))
                 (caar values))
                ((null (cdr values))
                 (car values))
                (t
                 (mapcar #'(lambda (x) (if (null (cdr x)) (car x) x))
                         values)))))))

(defun parse-command-line-for-argument-list (command-line &rest args)
  "Parse the command-line given in COMMAND-LINE in order to construct an
argument list for invoking another function, based on the specifications
given through the remaining arguments, which will be passed to the function
PARSE-COMMAND-LINE-ARGUMENTS for the parsing itself.  This function returns
an argument list, which will contain a position argument for each normal
argument to the function, followed by keyword arguments for each option
present in the command-line.  Duplicate options are merged, options with
no argument are turned into boolean T keyword arguments, and options with
only single arguments are unwrapped into single keyword arguments."
  (multiple-value-bind (prog-name arguments options)
      (apply #'parse-command-line-arguments command-line args)
    (declare (ignore prog-name))
    (append arguments (make-options-argument-list options))))

;;;
;;; Main Entry Point
;;;

(defun call-with-parsed-arguments (function command-line &rest args)
  "Invoke the given function with the arguments and options parsed out of the
command-line as given by COMMAND-LINE."
  (apply function 
         (apply #'parse-command-line-for-argument-list command-line args)))

(defun call-with-parsed-command-line (function &rest args)
  "Invoke the given function with the arguments and options parsed out of the
command-line as returned by GET-COMMAND-LINE-ARGUMENTS."
  (apply function 
         (apply #'parse-command-line-for-argument-list 
                (get-command-line-arguments) args)))

(defun parse-argument-lambda-list (lambda-list)
  (loop with state = :required
     with program-arg = nil
     with required-args = nil
     with optional-args = nil
     with rest-arg = nil
     with keyword-args = nil
     for arg in lambda-list
     do
       (if (member arg '(&optional &rest &program &key))
           (case arg
             (&optional
              (unless (eq state :required)
                (error "Misplaced &OPTIONAL in command-line lambda list: ~S"
                       lambda-list))
              (setq state :optional))
             (&rest
              (unless (member state '(:required :optional))
                (error "Misplaced &REST in command-line lambda list: ~S" 
                       lambda-list))
              (setq state :rest))
             (&program
              (unless (member state '(:required :optional :post-rest))
                (error "Misplaced &PROGRAM in command-line lambda list: ~S" 
                       lambda-list))
              (setq state :program))
             (&key
              (unless (member state
                              '(:required :optional :post-rest :post-program))
                (error "Misplaced &KEY in command-line lambda list: ~S"
                       lambda-list))
              (setq state :key)))
           (ecase state
             (:required (push arg required-args))
             (:optional (push arg optional-args))
             (:rest (setq rest-arg arg
                          state :post-rest))
             (:program (setq program-arg arg
                             state :post-program))
             (:key (push arg keyword-args))))
     finally
       (when (eq state :rest)
         (error "Missing &REST argument in command-line lambda list: ~S"
                lambda-list))
       (when (eq state :program)
         (error "Missing &PROGRAM argument in command-line lambda list: ~S"
                lambda-list))
       (return
         (values
          program-arg
          (nreverse required-args)
          (nreverse optional-args)
          rest-arg
          (nreverse keyword-args)))))

(defmacro with-parsed-arguments ((&rest lambda-list) command-line &body body)
  (multiple-value-bind (program-arg required-args optional-args
                                    rest-arg keyword-args)
      (parse-argument-lambda-list lambda-list)
    (let ((required-argcount (length required-args))
          (allowed-argcount (unless rest-arg
                              (+ (length required-args)
                                 (length optional-args))))
          (real-program-arg (or program-arg (gensym)))
          (argument-ll (append required-args
                               (when optional-args
                                 (cons '&optional optional-args))
                               (when rest-arg
                                 (list '&rest rest-arg)))))
      (multiple-value-bind (option-specs option-ll)
          (loop for (var name args . default) in keyword-args
             collect (list name var args) into option-specs
             collect `((,var ,var) ,(car default)) into option-ll
             finally
               (return (values option-specs (list* '&key option-ll))))
        (pmsf-lib:with-unique-names (arguments options)
          `(multiple-value-bind (,real-program-arg ,arguments ,options)
               (parse-command-line-arguments ,command-line 
                                             :option-specs ',option-specs
                                             :required-arguments 
                                             ,required-argcount
                                             :allowed-arguments
                                             ,allowed-argcount)
             (declare (ignorable ,real-program-arg))
             (destructuring-bind ((,@argument-ll) (,@option-ll))
                 (list ,arguments (make-options-argument-list ,options))
               ,@body)))))))

(defmacro with-parsed-command-line ((&rest lambda-list) &body body)
  `(with-parsed-arguments (,@lambda-list) (get-command-line-arguments)
     ,@body))