--- a/package.lisp Tue Dec 18 21:08:00 2018 -0500
+++ b/package.lisp Wed Dec 19 17:46:09 2018 -0500
@@ -1,13 +1,22 @@
(defpackage :adopt
(:use :cl)
(:export
+ :define-interface
:parse-options
+
:print-usage
- :define-interface
+ :print-usage-and-exit
+ :print-error-and-exit
:argv
:exit
+ :unrecognized-option
+ :problematic-option
+ :discard-option
+ :treat-as-argument
+ :supply-new-value
+
:flip
:oldest
:newest
--- a/src/main.lisp Tue Dec 18 21:08:00 2018 -0500
+++ b/src/main.lisp Wed Dec 19 17:46:09 2018 -0500
@@ -65,7 +65,7 @@
#-(or sbcl ccl) (error "ARGV is not supported on this implementation."))
(defun exit (&optional (code 0))
- #+sbcl (sb-ext:exit :code 0)
+ #+sbcl (sb-ext:exit :code code)
#-(or sbcl) (error "EXIT is not supported on this implementation."))
@@ -96,22 +96,32 @@
long
short
parameter
+ reduce
(initial-value nil initial-value?)
- (reduce (constantly t))
(key #'identity)
(finally #'identity))
+ (when (and (null long) (null short))
+ (error "Option ~A requires at least one of :long/:short." name))
+ (when (null reduce)
+ (error "Option ~A is missing required argument :reduce." name))
+ (when (and (member reduce (list 'collect #'collect
+ 'newest #'newest
+ 'oldest #'oldest))
+ (null parameter))
+ (error "Option ~A has reduce function ~A, which requires a :parameter."
+ name reduce))
(apply #'make-instance 'option
- :name name
- :result-key result-key
- :documentation documentation
- :long long
- :short short
- :parameter parameter
- :reduce reduce
- :key key
- :finally finally
- (when initial-value?
- (list :initial-value initial-value))))
+ :name name
+ :result-key result-key
+ :documentation documentation
+ :long long
+ :short short
+ :parameter parameter
+ :reduce reduce
+ :key key
+ :finally finally
+ (when initial-value?
+ (list :initial-value initial-value))))
(defclass interface ()
@@ -184,37 +194,50 @@
(string= "--" arg))
+(define-condition unrecognized-option (error)
+ ((problematic-option :accessor problematic-option :initarg :problematic-option))
+ (:report (lambda (condition stream)
+ (format stream "No such option ~S." (problematic-option condition)))))
+
+(defun unrecognized-option-p (value)
+ (typep value 'unrecognized-option))
+
+
(defun parse-long (interface results arg remaining)
(let* ((= (position #\= arg))
(long-name (subseq arg 2 =))
- (option (gethash long-name (long-options interface)))
- (k (result-key option))
- (current (gethash k results)))
- (setf (gethash k results)
- (if (parameter option)
- (let ((param (funcall (key option)
- (if =
- (subseq arg (1+ =))
- (pop remaining)))))
- (funcall (reducer option) current param))
- (funcall (reducer option) current))))
+ (option (gethash long-name (long-options interface))))
+ (when (null option)
+ (error 'unrecognized-option :problematic-option (format nil "--~A" long-name)))
+ (let* ((k (result-key option))
+ (current (gethash k results)))
+ (setf (gethash k results)
+ (if (parameter option)
+ (let ((param (funcall (key option)
+ (if =
+ (subseq arg (1+ =))
+ (pop remaining)))))
+ (funcall (reducer option) current param))
+ (funcall (reducer option) current)))))
remaining)
(defun parse-short (interface results arg remaining)
(let* ((short-name (aref arg 1))
- (option (gethash short-name (short-options interface)))
- (k (result-key option))
- (current (gethash k results)))
- (setf (gethash k results)
- (if (parameter option)
- (let ((param (funcall (key option)
- (if (> (length arg) 2)
- (subseq arg 2) ; -xfoo
- (pop remaining))))); -x foo
- (funcall (reducer option) current param))
- (prog1 (funcall (reducer option) current)
- (if (> (length arg) 2)
- (push (format nil "-~A" (subseq arg 2)) remaining))))))
+ (option (gethash short-name (short-options interface))))
+ (when (null option)
+ (error 'unrecognized-option :problematic-option (format nil "-~A" short-name)))
+ (let* ((k (result-key option))
+ (current (gethash k results)))
+ (setf (gethash k results)
+ (if (parameter option)
+ (let ((param (funcall (key option)
+ (if (> (length arg) 2)
+ (subseq arg 2) ; -xfoo
+ (pop remaining))))); -x foo
+ (funcall (reducer option) current param))
+ (prog1 (funcall (reducer option) current)
+ (if (> (length arg) 2)
+ (push (format nil "-~A" (subseq arg 2)) remaining)))))))
remaining)
@@ -232,6 +255,44 @@
results)
+(defun discard-option (condition)
+ "Invoke the `discard-option` restart properly.
+
+ Example:
+
+ (handler-bind ((unrecognized-option 'discard-option))
+ (multiple-value-bind (arguments options) (parse-options *ui*)
+ (run arguments options)))
+
+ "
+ (invoke-restart (find-restart 'discard-option condition)))
+
+(defun treat-as-argument (condition)
+ "Invoke the `treat-as-argument` restart properly.
+
+ Example:
+
+ (handler-bind ((unrecognized-option 'treat-as-argument))
+ (multiple-value-bind (arguments options) (parse-options *ui*)
+ (run arguments options)))
+
+ "
+ (invoke-restart (find-restart 'treat-as-argument condition)))
+
+(defun supply-new-value (condition value)
+ "Invoke the `supply-new-value` restart properly.
+
+ Example:
+
+ (handler-bind
+ ((unrecognized-option (alexandria:rcurry 'supply-new-value \"--foo\"))
+ (multiple-value-bind (arguments options) (parse-options *ui*)
+ (run arguments options)))
+
+ "
+ (invoke-restart (find-restart 'supply-new-value condition) value))
+
+
(defun parse-options (interface &optional (arguments (rest (argv))))
"Parse `arguments` according to `interface`.
@@ -245,8 +306,7 @@
"
(let ((toplevel nil)
- (results (make-hash-table))
- (options (options interface)))
+ (results (make-hash-table)))
(initialize-results interface results)
(labels
((recur (arguments)
@@ -255,15 +315,30 @@
(finalize-results interface results))
(destructuring-bind (arg . remaining) arguments
(recur
- (cond
- ((terminatorp arg) (dolist (r remaining) (push r toplevel)))
- ((shortp arg) (parse-short interface results arg remaining))
- ((longp arg) (parse-long interface results arg remaining))
- (t (push arg toplevel) remaining)))))))
+ (restart-case
+ (cond
+ ((terminatorp arg) (dolist (r remaining) (push r toplevel)))
+ ((shortp arg) (parse-short interface results arg remaining))
+ ((longp arg) (parse-long interface results arg remaining))
+ (t (push arg toplevel) remaining))
+ (discard-option ()
+ :test unrecognized-option-p
+ :report "Discard the unrecognized option."
+ remaining)
+ (treat-as-argument ()
+ :test unrecognized-option-p
+ :report "Treat the unrecognized option as a plain argument."
+ (push arg toplevel)
+ remaining)
+ (supply-new-value (v)
+ :test unrecognized-option-p
+ :report "Supply a new value to parse."
+ :interactive (lambda () (list (read-line)))
+ (cons v remaining))))))))
(recur arguments))))
-;;;; Printing Usage -----------------------------------------------------------
+;;;; Output -------------------------------------------------------------------
(defun option-string (option)
(let* ((long (long option))
(short (short option))
@@ -357,3 +432,44 @@
(doc-width (- width doc-column)))
(dolist (option (options interface))
(print-option-usage stream option option-column doc-column doc-width))))
+
+(defun print-usage-and-exit
+ (interface &key
+ (stream *standard-output*)
+ (program-name (first (argv)))
+ (width 80)
+ (option-width 20)
+ (exit-code 0))
+ "Print a pretty usage document for `interface` to `stream` and exit.
+
+ Handy for easily providing --help:
+
+ (multiple-value-bind (arguments options) (parse-options *ui*)
+ (when (gethash 'help options)
+ (print-usage-and-exit *ui*))
+ (run arguments options))
+ "
+ (print-usage interface
+ :stream stream
+ :program-name program-name
+ :width width
+ :option-width option-width)
+ (exit exit-code))
+
+(defun print-error-and-exit (error &key
+ (stream *error-output*)
+ (exit-code 1)
+ (prefix "error: "))
+ "Print `prefix` and `error` to `stream` and exit.
+
+ Example:
+
+ (handler-case
+ (multiple-value-bind (arguments options) (parse-options *ui*)
+ (run arguments options))
+ (unrecognized-option (c)
+ (print-error-and-exit c)))
+
+ "
+ (format stream "~A~A~%" (or prefix "") error)
+ (adopt:exit exit-code))