;;; Copyright (C) 2008 Magnus Henoch
;;;
;;; 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 2 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, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA

(in-package :darcs)

(define-condition invalid-arguments (simple-error)
  ())

;; The option struct describes a command line option.
(defstruct option
  ;; keyword for return value of GETOPT
  (keyword (error "No keyword specified.") :type keyword)
  ;; short name of one character
  (short nil :type (or character null))
  ;; long name
  (long nil :type (or string null))
  ;; does it take an argument?  if so, describe the argument type.
  (arg nil :type (or string null))
  ;; one-line help string
  (help (error "No help string specified.") :type string))

(defun getopt (args options &aux parsed leftover)
  "Process command line ARGS, as specified by OPTIONS.
ARGS is a list of strings.
OPTIONS is a list of OPTION structs.

Return two values: a alist of parsed options, and a list of leftover args.
The keys of the alists are the keywords of the options found, and the
values are the provided arguments, or T if the option takes no argument."
  (flet ((what (arg)
	   (cond
	     ((string= arg "--")
	      :pass)
	     ((and (>= (length arg) 2)
		   (string= arg "--" :end1 2))
	      :long)
	     ((and (>= (length arg) 1)
		   (string= arg "-" :end1 1))
	      :short)
	     (t
	      nil)))
	 (maybe-get-argument (arg opt &key no-argument)
	   (push (cons (option-keyword opt)
		       (if (option-arg opt)
			   (if (or no-argument (null args))
			       (error 'invalid-arguments
				      :format-control "Option ~A requires an argument."
				      :format-arguments (list arg))
			       (pop args))
			   t))
		 parsed))
	 (maybe-split-long-option (arg)
	   (let ((equal-pos (position #\= arg)))
	     (if equal-pos
		 (progn
		   (push (subseq arg (1+ equal-pos)) args)
		   (subseq arg 2 equal-pos))
		 (subseq arg 2)))))

    (loop while args do
	 (ecase (what (car args))
	   (:pass
	    ;; Got "--".  Skip it and return the remaining arguments
	    ;; without checking.
	    (pop args)
	    (return-from getopt (values parsed (append (nreverse leftover) args))))

	   (:long
	    ;; Got a long option.  Identify it and retrieve its
	    ;; argument, if any.
	    (let* ((arg (pop args))
		   (long-option (maybe-split-long-option arg))
		   (option (find long-option options :key #'option-long :test #'string=)))
	      (unless option
		(error 'invalid-arguments
		       :format-control "Unknown long option ~S (none of ~{~S ~})."
		       :format-arguments (list arg (mapcar #'option-long options))))
	      (maybe-get-argument arg option)))

	   (:short
	    ;; Got a string of short options.  Identify them all.
	    (let* ((arg (pop args))
		   (letters (map 'list #'identity (subseq arg 1))))

	      (loop while letters
		 do
		   (let* ((letter (pop letters))
			  (option (find letter options :key #'option-short)))
		     (unless option
		       (error 'invalid-arguments
			      :format-control "Unknown option ~A."
			      :format-arguments (list letter)))
		     ;; Only the last short option can have an argument.
		     (maybe-get-argument letter option 
					 :no-argument (not (null letters)))))))

	   ((nil)
	    ;; Not an option - leftover args.
	    (push (pop args) leftover))))

    (values parsed (nreverse leftover))))