# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1545259569 18000
# Node ID 49a9f77d515f0df79d8dda40312c85cb466d3849
# Parent  35cff9a179f4d6d02714cd23f95471c0caf9902c
Add restarts and more

diff -r 35cff9a179f4 -r 49a9f77d515f package.lisp
--- 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
diff -r 35cff9a179f4 -r 49a9f77d515f src/main.lisp
--- 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))