# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1554200269 14400
# Node ID 34d2ad201c73fa9e42b9181364abcdfc6189ec73
# Parent  3487644c33e96385c4e2f129fa40cd954d87d858
Add groups, restructure and simplify API

diff -r 3487644c33e9 -r 34d2ad201c73 .lispwords
--- a/.lispwords	Fri Mar 01 14:47:30 2019 -0500
+++ b/.lispwords	Tue Apr 02 06:17:49 2019 -0400
@@ -0,0 +1,1 @@
+(1 make-option)
diff -r 3487644c33e9 -r 34d2ad201c73 adopt.asd
--- a/adopt.asd	Fri Mar 01 14:47:30 2019 -0500
+++ b/adopt.asd	Tue Apr 02 06:17:49 2019 -0400
@@ -1,5 +1,5 @@
 (asdf:defsystem :adopt
-  :description "Simple, flexible UNIX-style option parsing."
+  :description "Simple, flexible, UNIX-style option parsing."
   :author "Steve Losh <steve@stevelosh.com>"
   :homepage "https://sjl.bitbucket.io/adopt/"
 
@@ -11,9 +11,9 @@
   :in-order-to ((asdf:test-op (asdf:test-op :adopt/test)))
 
   :serial t
-  :components ((:file "package")
-               (:module "src" :serial t
-                :components ((:file "main")))))
+  :components ((:module "src" :serial t
+                :components ((:file "package")
+                             (:file "main")))))
 
 
 (asdf:defsystem :adopt/test
@@ -25,10 +25,10 @@
   :depends-on (:adopt :1am :losh)
 
   :serial t
-  :components ((:file "package.test")
-               (:module "test"
+  :components ((:module "test"
                 :serial t
-                :components ((:file "tests"))))
+                :components ((:file "package")
+                             (:file "tests"))))
 
   :perform (asdf:test-op (op system)
              (funcall (read-from-string "adopt.test:run-tests"))))
diff -r 3487644c33e9 -r 34d2ad201c73 package.lisp
--- a/package.lisp	Fri Mar 01 14:47:30 2019 -0500
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,33 +0,0 @@
-(defpackage :adopt
-  (:use :cl)
-  (:export
-    :define-interface
-    :define-string
-
-    :make-interface
-    :make-option
-
-    :parse-options
-
-    :print-usage
-    :print-usage-and-exit
-    :print-error-and-exit
-    :print-manual
-
-    :argv
-    :exit
-
-    :unrecognized-option
-    :problematic-option
-    :discard-option
-    :treat-as-argument
-    :supply-new-value
-
-    :flip
-    :oldest
-    :newest
-    :collect
-
-
-    )
-  (:shadow :collect :documentation :reduce))
diff -r 3487644c33e9 -r 34d2ad201c73 package.test.lisp
--- a/package.test.lisp	Fri Mar 01 14:47:30 2019 -0500
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,3 +0,0 @@
-(defpackage :adopt.test
-  (:use :cl :1am :adopt)
-  (:export :run-tests))
diff -r 3487644c33e9 -r 34d2ad201c73 src/main.lisp
--- a/src/main.lisp	Fri Mar 01 14:47:30 2019 -0500
+++ b/src/main.lisp	Tue Apr 02 06:17:49 2019 -0400
@@ -56,7 +56,7 @@
   "Return a list of the program name and command line arguments.
 
   This is not implemented for every Common Lisp implementation.  You can always
-  pass your own values to `parse-options` and `print-usage` if it's not
+  pass your own values to `parse-options` and `print-help` if it's not
   implemented for your particular Lisp.
 
   "
@@ -83,31 +83,39 @@
   `(defparameter ,var (format nil ,string ,@args)))
 
 
+(defmacro defclass* (name &rest slots)
+  `(defclass ,name ()
+     ,(loop :for slot :in slots
+            :for initarg = (intern (symbol-name slot) :keyword)
+            :collect `(,slot :initarg ,initarg :accessor ,slot))))
+
+
 ;;;; Definition ---------------------------------------------------------------
-(defclass option ()
-  ((name :initarg :name :accessor name)
-   (documentation :initarg :documentation :accessor documentation)
-   (manual :initarg :manual :accessor manual)
-   (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)))
+(defclass* option
+  name
+  result-key
+  help
+  manual
+  short
+  long
+  parameter
+  initial-value
+  key
+  finally
+  reduce)
 
 (defmethod print-object ((o option) stream)
   (print-unreadable-object (o stream :type t)
     (format stream "~A ~A/~A" (name o) (short o) (long o))))
 
-(defun make-option (name result-key &key
+(defun make-option (name &key
                     long
                     short
-                    documentation
+                    help
                     manual
                     parameter
                     reduce
+                    (result-key name)
                     (initial-value nil initial-value?)
                     (key #'identity)
                     (finally #'identity))
@@ -115,8 +123,8 @@
     (error "Option ~A requires at least one of :long/:short." name))
   (when (null reduce)
     (error "Option ~A is missing required argument :reduce." name))
-  (when (null documentation)
-    (error "Option ~A is missing required argument :documentation" name))
+  (when (null help)
+    (error "Option ~A is missing required argument :help" name))
   (when (and (member reduce (list 'collect #'collect
                                   'newest #'newest
                                   'oldest #'oldest))
@@ -126,7 +134,7 @@
   (apply #'make-instance 'option
          :name name
          :result-key result-key
-         :documentation documentation
+         :help help
          :manual manual
          :long long
          :short short
@@ -137,77 +145,84 @@
          (when initial-value?
            (list :initial-value initial-value))))
 
+(defun optionp (object)
+  (typep object 'option))
 
-(defclass interface ()
-  ((name :initarg :name :accessor name)
-   (summary :initarg :summary :accessor summary)
-   (examples :initarg :examples :accessor examples)
-   (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)
-   (documentation :initarg :documentation :accessor documentation)
-   (manual :initarg :manual :accessor manual)))
+
+(defclass* group
+  name title help manual options)
+
+(defmethod print-object ((g group) stream)
+  (print-unreadable-object (g stream :type t)
+    (format stream "~A (~D options)" (name g) (length (options g)))))
+
+(defun make-group (name &key title help manual options)
+  (make-instance 'group
+    :name name
+    :title title
+    :help help
+    :manual manual
+    :options options))
+
+(defun make-default-group (options)
+  (make-instance 'group
+    :name nil
+    :title nil
+    :help nil
+    :manual nil
+    :options options))
+
+(defun groupp (object)
+  (typep object 'group))
+
+
+(defclass* interface
+  name
+  summary
+  examples
+  options
+  groups
+  short-options
+  long-options
+  usage
+  help
+  manual)
 
 (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)))
-                    (options i)))))
+    (format stream "~A (~D options in ~D groups)"
+            (name i)
+            (length (options i))
+            (length (groups i)))))
 
-(defun make-interface (&key name summary usage documentation manual examples options)
-  (let ((interface (make-instance 'interface
-                     :options nil
-                     :name name
-                     :usage usage
-                     :summary summary
-                     :documentation documentation
-                     :manual manual
-                     :examples examples
-                     :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)))
-        (when short
-          (setf (gethash short (short-options interface)) option))
-        (when long
-          (setf (gethash long (long-options interface)) option))))
-    (funcallf (options interface) #'nreverse)
+(defun make-interface (&key name summary usage help manual examples contents)
+  (let* ((ungrouped-options (remove-if-not #'optionp contents))
+         (groups (cons (make-default-group ungrouped-options)
+                       (remove-if-not #'groupp contents)))
+         (options (loop :for g :in groups :append (options g)))
+         (interface (make-instance 'interface
+                      :name name
+                      :usage usage
+                      :summary summary
+                      :help help
+                      :manual manual
+                      :examples examples
+                      :groups groups
+                      :options options
+                      :short-options (make-hash-table)
+                      :long-options (make-hash-table :test #'equal))))
+    (flet ((add-option (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)))))
+      (dolist (g groups)
+        (map nil #'add-option (options g))))
     interface))
 
 
-(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 (&key name summary usage documentation manual examples) &body options)
-  `(defparameter ,symbol
-     (make-interface
-       :name ,name
-       :summary ,summary
-       :usage ,usage
-       :documentation ,documentation
-       :manual ,manual
-       :examples ,examples
-       :options
-       (list
-         ,@(loop
-             :for (name-and-result-key . args) :in options
-             :for (option-name result-key) = (resolve-names name-and-result-key)
-             :collect `(make-option ',option-name ',result-key ,@args))))))
-
-
 ;;;; Parsing ------------------------------------------------------------------
 (defun shortp (arg)
   (and (> (length arg) 1)
@@ -246,8 +261,8 @@
                                     (if =
                                       (subseq arg (1+ =))
                                       (pop remaining)))))
-                (funcall (reducer option) current param))
-              (funcall (reducer option) current)))))
+                (funcall (reduce option) current param))
+              (funcall (reduce option) current)))))
   remaining)
 
 (defun parse-short (interface results arg remaining)
@@ -263,8 +278,8 @@
                                     (if (> (length arg) 2)
                                       (subseq arg 2) ; -xfoo
                                       (pop remaining))))); -x foo
-                (funcall (reducer option) current param))
-              (prog1 (funcall (reducer option) current)
+                (funcall (reduce option) current param))
+              (prog1 (funcall (reduce option) current)
                 (if (> (length arg) 2)
                   (push (format nil "-~A" (subseq arg 2)) remaining)))))))
   remaining)
@@ -331,7 +346,7 @@
      to any options defined in `interface`.
   2. An `EQL` hash table of option keys to values.
 
-  See the full usage documentation for more information.
+  See the full documentation for more information.
 
   "
   (let ((toplevel nil)
@@ -367,7 +382,7 @@
       (recur arguments))))
 
 
-;;;; Usage --------------------------------------------------------------------
+;;;; Help ---------------------------------------------------------------------
 (defun option-string (option)
   (let* ((long (long option))
          (short (short option))
@@ -382,18 +397,18 @@
                           (when long
                             (format nil "--~A~A" long parameter-string)))))))
 
-(defun print-option-usage (stream option option-column doc-column doc-width)
-  "Print `option`'s usage to `stream`, indented/wrapped properly.
+(defun print-option-help (stream option option-column doc-column doc-width)
+  "Print `option`'s help to `stream`, indented/wrapped properly.
 
   Assumes the last thing printed to `stream` was a newline.
 
-  The option string will start at `option-column`.  The documentation will start
-  at `doc-column` and be line-wrapped to `doc-width`.
+  The option string will start at `option-column`.  The help will start at
+  `doc-column` and be line-wrapped to `doc-width`.
 
   "
   (let ((option-string (option-string option))
         (lines (bobbin:wrap (split-sequence:split-sequence
-                              #\newline (documentation option))
+                              #\newline (help option))
                             doc-width))
         (col 0))
     (flet ((print-at (c string &optional newline)
@@ -410,13 +425,13 @@
       (dolist (line lines)
         (print-at doc-column line t)))))
 
-(defun print-usage (interface &key
-                    (stream *standard-output*)
-                    (program-name (first (argv)))
-                    (width 80)
-                    (option-width 20)
-                    (include-examples t))
-  "Print a pretty usage document for `interface` to `stream`.
+(defun print-help (interface &key
+                   (stream *standard-output*)
+                   (program-name (first (argv)))
+                   (width 80)
+                   (option-width 20)
+                   (include-examples t))
+  "Print a pretty help document for `interface` to `stream`.
 
   `width` should be the total width (in characters) for line-wrapping purposes.
   Care will be taken to ensure lines are no longer than this, though some edge
@@ -424,13 +439,13 @@
   through.
 
   `option-width` should be the width of the column of short/long options (in
-  characters).  If the short/long option documentation is shorter than this, the
-  option's documentation string will start on the same line.  Otherwise the
-  option's documentation string will start on the next line.
+  characters).  If the short/long option help is shorter than this, the option's
+  help string will start on the same line.  Otherwise the option's help string
+  will start on the next line.
 
   The result will look something like:
 
-    (print-usage *program-interface* :width 60 :option-width 15)
+    (print-help *program-interface* :width 60 :option-width 15)
     ; =>
     ; foo - do some things and meow
     ;
@@ -457,17 +472,19 @@
     width option-width)
   (format stream "~A - ~A~2%" (name interface) (summary 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))
-         (doc-width (- width doc-column))
-         (examples (examples interface))
+  (format stream (bobbin:wrap (help interface) width))
+  (format stream "~%")
+  (dolist (group (groups interface))
+    (format stream "~%~A:~%" (or (title group) (name group) "Options"))
+    (let* ((option-column 2)
+           (option-padding 2)
+           (doc-column (+ option-column option-width option-padding))
+           (doc-width (- width doc-column)))
+      (dolist (option (options group))
+        (print-option-help stream option option-column doc-column doc-width))))
+  (let* ((examples (examples interface))
          (example-column 2)
          (example-width (- width example-column)))
-    (dolist (option (options interface))
-      (print-option-usage stream option option-column doc-column doc-width))
     (when (and examples include-examples)
       (format stream "~%Examples:~%")
       (loop :for (prose . command) :in examples :do
@@ -475,7 +492,7 @@
                     (bobbin:wrap (list prose) example-width)
                     command)))))
 
-(defun print-usage-and-exit
+(defun print-help-and-exit
     (interface &key
      (stream *standard-output*)
      (program-name (first (argv)))
@@ -483,16 +500,16 @@
      (option-width 20)
      (include-examples t)
      (exit-code 0))
-  "Print a pretty usage document for `interface` to `stream` and exit.
+  "Print a pretty help 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*))
+        (print-help-and-exit *ui*))
       (run arguments options))
   "
-  (print-usage interface
+  (print-help interface
                :stream stream
                :program-name program-name
                :width width
@@ -582,16 +599,24 @@
        (print-description ()
          (f ".SH DESCRIPTION")
          (fa (split-paragraphs (or (manual interface)
-                                   (documentation interface)))))
+                                   (help interface)))))
        (print-option (option)
          (f ".TP")
          (fa (option-troff option))
          (fa (split-paragraphs
-               (or (manual option) (documentation option))
+               (or (manual option) (help option))
                :delimiter ".IP")))
-       (print-options ()
-         (f ".SH OPTIONS")
-         (map nil #'print-option (options interface)))
+       (print-group (group)
+         (if (title group)
+           (f ".SS ~A" (escape (title group)))
+           (f ".SH OPTIONS"))
+         (let ((desc (or (manual group)
+                         (help group))))
+           (when desc
+             (fa (split-paragraphs desc))))
+         (map nil #'print-option (options group)))
+       (print-groups ()
+         (map nil #'print-group (groups interface)))
        (print-example (prose command prefix)
          (f prefix)
          (fa (escape prose))
@@ -610,5 +635,5 @@
     (print-name)
     (print-synopsis)
     (print-description)
-    (print-options)
+    (print-groups)
     (print-examples)))
diff -r 3487644c33e9 -r 34d2ad201c73 src/package.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/package.lisp	Tue Apr 02 06:17:49 2019 -0400
@@ -0,0 +1,32 @@
+(defpackage :adopt
+  (:use :cl)
+  (:export
+    :define-string
+
+    :make-option
+    :make-group
+    :make-interface
+
+    :parse-options
+
+    :print-help
+    :print-help-and-exit
+    :print-error-and-exit
+    :print-manual
+
+    :argv
+    :exit
+
+    :unrecognized-option
+    :problematic-option
+    :discard-option
+    :treat-as-argument
+    :supply-new-value
+
+    :flip
+    :oldest
+    :newest
+    :collect
+
+    )
+  (:shadow :collect :reduce))
diff -r 3487644c33e9 -r 34d2ad201c73 test/package.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/test/package.lisp	Tue Apr 02 06:17:49 2019 -0400
@@ -0,0 +1,3 @@
+(defpackage :adopt.test
+  (:use :cl :1am :adopt)
+  (:export :run-tests))