# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1545185280 18000
# Node ID 35cff9a179f4d6d02714cd23f95471c0caf9902c
# Parent  23baaf9d4f31ee05599db6ee4f38d408917d9503
Add all the stuff from dogfooding

diff -r 23baaf9d4f31 -r 35cff9a179f4 Makefile
--- a/Makefile	Thu Nov 22 00:47:41 2018 -0500
+++ b/Makefile	Tue Dec 18 21:08:00 2018 -0500
@@ -10,19 +10,19 @@
 
 test-sbcl:
 	$(heading_printer) computer 'SBCL'
-	sbcl --load test/run.lisp
+	time sbcl --load test/run.lisp
 
 test-ccl:
 	$(heading_printer) slant 'CCL'
-	ccl --load test/run.lisp
+	time ccl --load test/run.lisp
 
 test-ecl:
 	$(heading_printer) roman 'ECL'
-	ecl -load test/run.lisp
+	time ecl -load test/run.lisp
 
 test-abcl:
 	$(heading_printer) broadway 'ABCL'
-	abcl --load test/run.lisp
+	time abcl --load test/run.lisp
 
 # Documentation ---------------------------------------------------------------
 $(apidocs): $(sourcefiles)
diff -r 23baaf9d4f31 -r 35cff9a179f4 package.lisp
--- a/package.lisp	Thu Nov 22 00:47:41 2018 -0500
+++ b/package.lisp	Tue Dec 18 21:08:00 2018 -0500
@@ -6,7 +6,12 @@
     :define-interface
 
     :argv
+    :exit
 
-    :latest
-    :append1
-    ))
+    :flip
+    :oldest
+    :newest
+    :collect
+
+    )
+  (:shadow :collect :documentation :reduce))
diff -r 23baaf9d4f31 -r 35cff9a179f4 src/main.lisp
--- a/src/main.lisp	Thu Nov 22 00:47:41 2018 -0500
+++ b/src/main.lisp	Tue Dec 18 21:08:00 2018 -0500
@@ -1,19 +1,36 @@
 (in-package :adopt)
 
 ;;;; Utils --------------------------------------------------------------------
-(defun append1 (list el)
-  "Append element `el` to the end of `list`.
+(defun flip (function)
+  "Return a function of two arguments X and Y that calls `function` with Y and X.
+
+  Useful for wrapping existing functions that expect their arguments in the
+  opposite order.
+
+  Examples:
 
-  This is implemented as `(append list (list el))`.  It is not particularly
-  fast.
+    (funcall #'cons 1 2)        ; => (1 . 2)
+    (funcall (flip #'cons) 1 2) ; => (2 . 1)
+    (reduce (flip #'cons) '(1 2 3) :initial-value nil)
+    ; => (3 2 1)
+
+  "
+  (lambda (x y)
+    (funcall function y x)))
+
+(defun collect (list el)
+  "Append element `el` to the end of `list`.
 
   It is useful as a `:reduce` function when you want to collect all values given
   for an option.
 
+  This is implemented as `(append list (list el))`.  It is not particularly
+  fast.  If you can live with reversed output consider `(flip #'cons)`  instead.
+
   "
   (append list (list el)))
 
-(defun latest (old new)
+(defun newest (old new)
   "Return `new`.
 
   It is useful as a `:reduce` function when you want to just keep the last-given
@@ -23,6 +40,17 @@
   (declare (ignore old))
   new)
 
+(defun oldest (old new)
+  "Return `new` if `old` is `nil`, otherwise return `old`.
+
+  It is useful as a `:reduce` function when you want to just keep the
+  first-given value for an option.
+
+  "
+  (if (null old)
+    new
+    old))
+
 
 (defun argv ()
   "Return a list of the program name and command line arguments.
@@ -36,71 +64,109 @@
   #+ccl ccl:*unprocessed-command-line-arguments*
   #-(or sbcl ccl) (error "ARGV is not supported on this implementation."))
 
+(defun exit (&optional (code 0))
+  #+sbcl (sb-ext:exit :code 0)
+  #-(or sbcl) (error "EXIT is not supported on this implementation."))
+
+
+(defun funcall% (value function)
+  (funcall function value))
+
+(define-modify-macro funcallf (function) funcall%)
+
 
 ;;;; Definition ---------------------------------------------------------------
 (defclass option ()
-  ((name :initarg :name :accessor name%)
-   (documentation :initarg :documentation :accessor documentation%)
-   (short :initarg :short :accessor short%)
-   (long :initarg :long :accessor long%)
-   (parameter :initarg :parameter :accessor parameter%)
-   (initial-value :initarg :initial-value :accessor initial-value%)
-   (reduce :initarg :reduce :accessor reduce%)))
+  ((name :initarg :name :accessor name)
+   (documentation :initarg :documentation :accessor documentation)
+   (short :initarg :short :accessor short)
+   (long :initarg :long :accessor long)
+   (parameter :initarg :parameter :accessor parameter)
+   (initial-value :initarg :initial-value :accessor initial-value)
+   (key :initarg :key :accessor key)
+   (result-key :initarg :result-key :accessor result-key)
+   (finally :initarg :finally :accessor finally)
+   (reducer :initarg :reduce :accessor reducer)))
 
 (defmethod print-object ((o option) stream)
   (print-unreadable-object (o stream :type t)
-    (format stream "~A ~A/~A" (name% o) (short% o) (long% o))))
+    (format stream "~A ~A/~A" (name o) (short o) (long o))))
 
-(defun make-option (name documentation &key
-                    long short parameter initial-value reduce)
-  (make-instance 'option
+(defun make-option (name result-key documentation &key
+                    long
+                    short
+                    parameter
+                    (initial-value nil initial-value?)
+                    (reduce (constantly t))
+                    (key #'identity)
+                    (finally #'identity))
+  (apply #'make-instance 'option
     :name name
+    :result-key result-key
     :documentation documentation
     :long long
     :short short
     :parameter parameter
-    :initial-value initial-value
-    :reduce (or reduce (constantly t))))
+    :reduce reduce
+    :key key
+    :finally finally
+    (when initial-value?
+      (list :initial-value initial-value))))
 
 
 (defclass interface ()
   ((options :initarg :options :accessor options)
    (short-options :initarg :short-options :accessor short-options)
    (long-options :initarg :long-options :accessor long-options)
-   (usage :initarg :usage :accessor usage)))
+   (usage :initarg :usage :accessor usage)
+   (documentation :initarg :documentation :accessor documentation)))
 
 (defmethod print-object ((i interface) stream)
   (print-unreadable-object (i stream :type t)
     (format stream "~{~A~^ ~}"
             (mapcar (lambda (o)
                       (format nil "(~A ~A/~A)"
-                              (name% o)
-                              (short% o)
-                              (long% o)))
+                              (name o)
+                              (short o)
+                              (long o)))
                     (options i)))))
 
-(defun make-interface (usage &rest options)
+(defun make-interface (usage documentation &rest options)
   (let ((interface (make-instance 'interface
                      :options nil
                      :usage usage
+                     :documentation documentation
                      :short-options (make-hash-table)
                      :long-options (make-hash-table :test #'equal))))
     (dolist (option options)
       (push option (options interface))
-      (let ((short (short% option))
-            (long (long% option)))
+      (let ((short (short option))
+            (long (long option)))
         (when short
           (setf (gethash short (short-options interface)) option))
         (when long
           (setf (gethash long (long-options interface)) option))))
-    (setf (options interface) (reverse (options interface)))
+    (funcallf (options interface) #'nreverse)
     interface))
 
-(defmacro define-interface (name usage &rest options)
-  `(defparameter ,name
-     (make-interface ,usage
-                     ,@(loop :for (name . args) :in options :collect
-                             `(make-option ',name ,@args)))))
+
+(defun resolve-names (name)
+  (etypecase name
+    (symbol (list name name))
+    ((cons symbol null)
+     (list (first name) (first name)))
+    ((cons symbol (cons symbol null))
+     name)))
+
+(defmacro define-interface (symbol usage documentation &rest options)
+  `(defparameter ,symbol
+     (make-interface
+       ,usage
+       ,documentation
+       ,@(loop
+           :for (name-and-result-key documentation . args) :in options
+           :for (option-name result-key) = (resolve-names name-and-result-key)
+           :collect `(make-option ',option-name ',result-key ,documentation ,@args)))))
 
 
 ;;;; Parsing ------------------------------------------------------------------
@@ -122,33 +188,50 @@
   (let* ((= (position #\= arg))
          (long-name (subseq arg 2 =))
          (option (gethash long-name (long-options interface)))
-         (name (name% option))
-         (current (gethash name results)))
-    (setf (gethash name results)
-          (if (parameter% option)
-            (funcall (reduce% option) current
-                     (if =
-                       (subseq arg (1+ =))
-                       (pop remaining)))
-            (funcall (reduce% option) current))))
+         (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)))
-         (name (name% option))
-         (current (gethash name results)))
-    (setf (gethash name results)
-          (if (parameter% option)
-            (funcall (reduce% option) current (if (> (length arg) 2)
-                                                (subseq arg 2) ; -xfoo
-                                                (pop remaining))) ; -x foo
-            (prog1 (funcall (reduce% option) current)
+         (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)
 
 
+(defun initialize-results (interface results)
+  (dolist (option (options interface))
+    (when (slot-boundp option 'initial-value)
+      (setf (gethash (result-key option) results)
+            (initial-value option))))
+  results)
+
+(defun finalize-results (interface results)
+  (dolist (option (options interface))
+    (funcallf (gethash (result-key option) results)
+              (finally option)))
+  results)
+
+
 (defun parse-options (interface &optional (arguments (rest (argv))))
   "Parse `arguments` according to `interface`.
 
@@ -156,19 +239,20 @@
 
   1. A fresh list of top-level, unaccounted-for arguments that don't correspond
      to any options defined in `interface`.
-  2. An `EQL` hash map of option `name`s to values.
+  2. An `EQL` hash table of option `name`s to values.
 
   See the full usage documentation for more information.
 
   "
   (let ((toplevel nil)
-        (results (make-hash-table)))
-    (dolist (option (options interface))
-      (setf (gethash (name% option) results) (initial-value% option)))
+        (results (make-hash-table))
+        (options (options interface)))
+    (initialize-results interface results)
     (labels
         ((recur (arguments)
            (if (null arguments)
-             (values (reverse toplevel) results)
+             (values (nreverse toplevel)
+                     (finalize-results interface results))
              (destructuring-bind (arg . remaining) arguments
                (recur
                  (cond
@@ -181,9 +265,9 @@
 
 ;;;; Printing Usage -----------------------------------------------------------
 (defun option-string (option)
-  (let* ((long (long% option))
-         (short (short% option))
-         (parameter (parameter% option))
+  (let* ((long (long option))
+         (short (short option))
+         (parameter (parameter option))
          (parameter-string (if parameter
                              (format nil " ~A" parameter)
                              "")))
@@ -205,7 +289,7 @@
   "
   (let ((option-string (option-string option))
         (lines (bobbin:wrap (split-sequence:split-sequence
-                              #\newline (documentation% option))
+                              #\newline (documentation option))
                             doc-width))
         (col 0))
     (flet ((print-at (c string &optional newline)
@@ -240,12 +324,14 @@
   option's documentation string will start on the next line.
 
   The result will look something like (assuming a usage string of
-  `\"[options] FILES\"`):
+  `\"[options] FILES\"` and a documentation string of `\"Intro.\"`):
 
     (print-usage *program-interface* :width 60 :option-width 15)
     ; =>
     ; USAGE: /bin/foo [options] FILES
     ;
+    ; Intro.
+    ;
     ; Options:
     ;   -v, --verbose    Output extra information.
     ;   -q, --quiet      Shut up.
@@ -262,7 +348,9 @@
   (assert (> width (+ 2 option-width 2)) (width option-width)
     "WIDTH (~D) must be at least 4 greater than OPTION-WIDTH (~D)"
     width option-width)
-  (format stream "USAGE: ~A ~A~2%Options:~%" program-name (usage interface))
+  (format stream "USAGE: ~A ~A~2%" program-name (usage interface))
+  (format stream (bobbin:wrap (documentation interface) width))
+  (format stream "~2%Options:~%")
   (let* ((option-column 2)
          (option-padding 2)
          (doc-column (+ option-column option-width option-padding))
diff -r 23baaf9d4f31 -r 35cff9a179f4 test/run.lisp
--- a/test/run.lisp	Thu Nov 22 00:47:41 2018 -0500
+++ b/test/run.lisp	Tue Dec 18 21:08:00 2018 -0500
@@ -1,5 +1,5 @@
 #+ecl (setf compiler:*user-cc-flags* "-Wno-shift-negative-value")
 
 (ql:quickload :adopt :silent t)
-(time (asdf:test-system :adopt))
+(asdf:test-system :adopt)
 (quit)
diff -r 23baaf9d4f31 -r 35cff9a179f4 test/tests.lisp
--- a/test/tests.lisp	Thu Nov 22 00:47:41 2018 -0500
+++ b/test/tests.lisp	Tue Dec 18 21:08:00 2018 -0500
@@ -39,10 +39,6 @@
        (is (hash-table-equal ,expected-result ,result)))))
 
 
-(defmethod print-object ((o hash-table) s)
-  (losh:pretty-print-hash-table s o))
-
-
 ;;;; Tests --------------------------------------------------------------------
 (define-interface *noop* "usage")
 (define-interface *option-types* "usage"
@@ -93,6 +89,40 @@
     :initial-value "hello"
     :reduce (constantly "goodbye")))
 
+(define-interface *keys* "keys"
+  (num
+    "num"
+    :long "num"
+    :parameter "NUMBER"
+    :initial-value nil
+    :key #'parse-integer
+    :reduce (flip #'cons))
+  (len
+    "len"
+    :long "len"
+    :parameter "STRING"
+    :initial-value nil
+    :key #'length
+    :reduce (flip #'cons)))
+
+(define-interface *finally* "finally"
+  (yell
+    "yell"
+    :short #\y
+    :parameter "STRING"
+    :initial-value "default"
+    :reduce #'newest
+    :finally #'string-upcase)
+  (a
+    "ensure a"
+    :short #\a
+    :parameter "STRING"
+    :initial-value "x"
+    :reduce #'newest
+    :finally (lambda (a)
+               (assert (string= "a" a))
+               :ok)))
+
 (define-interface *parameters* "usage"
   (no-param
     "no parameter"
@@ -105,6 +135,28 @@
     :parameter "P"
     :reduce #'(lambda (old new) old new)))
 
+(define-interface *helpers* "usage"
+  (oldest
+    "oldest"
+    :short #\o
+    :parameter "X"
+    :reduce #'oldest)
+  (newest
+    "newest"
+    :short #\n
+    :parameter "X"
+    :reduce #'newest)
+  (collect
+    "collect"
+    :short #\c
+    :parameter "X"
+    :reduce #'collect)
+  (flip
+    "flip"
+    :short #\f
+    :parameter "X"
+    :reduce (flip #'cons)))
+
 
 (define-test noop
   (check *noop* ""
@@ -181,6 +233,24 @@
          '("x" "y")
          (result 'foo "goodbye")))
 
+(define-test keys
+  (check *keys* ""
+         '()
+         (result 'len '()
+                 'num '()))
+  (check *keys* "--num 123 --num 0 --len abc --len 123456"
+         '()
+         (result 'num '(0 123)
+                 'len '(6 3))))
+
+(define-test finally
+  (check *finally* "-a a"
+         '()
+         (result 'yell "DEFAULT" 'a :ok))
+  (check *finally* "-y foo -y bar -a x -a a"
+         '()
+         (result 'yell "BAR" 'a :ok)))
+
 (define-test parameters
   (check *parameters* ""
          '()
@@ -198,3 +268,17 @@
          '("baz")
          (result 'no-param 2
                  'param "bar")))
+
+(define-test helpers
+  (check *helpers* ""
+         '()
+         (result 'oldest nil
+                 'newest nil
+                 'collect nil
+                 'flip nil))
+  (check *helpers* "-o1 -o2 -n1 -n2 -c1 -c2 -f1 -f2"
+         '()
+         (result 'oldest "1"
+                 'newest "2"
+                 'collect '("1" "2")
+                 'flip '("2" "1"))))