845fc8785d54

Initial commit
[view raw] [browse files]
author Steve Losh <steve@stevelosh.com>
date Wed, 21 Nov 2018 23:22:18 -0500
parents
children 152830fa3f85
branches/tags (none)
files .ffignore .hgignore .lispwords LICENSE.markdown Makefile README.markdown adopt.asd package.lisp package.test.lisp src/main.lisp test/run.lisp test/tests.lisp

Changes

diff -r 000000000000 -r 845fc8785d54 .ffignore
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/.ffignore	Wed Nov 21 23:22:18 2018 -0500
@@ -0,0 +1,1 @@
+docs/build
diff -r 000000000000 -r 845fc8785d54 .hgignore
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/.hgignore	Wed Nov 21 23:22:18 2018 -0500
@@ -0,0 +1,5 @@
+syntax: glob
+
+scratch.lisp
+*.png
+docs/build
diff -r 000000000000 -r 845fc8785d54 .lispwords
diff -r 000000000000 -r 845fc8785d54 LICENSE.markdown
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/LICENSE.markdown	Wed Nov 21 23:22:18 2018 -0500
@@ -0,0 +1,19 @@
+Copyright (c) 2018 Steve Losh and contributors
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
diff -r 000000000000 -r 845fc8785d54 Makefile
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Makefile	Wed Nov 21 23:22:18 2018 -0500
@@ -0,0 +1,22 @@
+.PHONY: test test-sbcl test-ccl test-ecl test-abcl
+
+heading_printer = $(shell which heading || echo 'true')
+
+# Testing ---------------------------------------------------------------------
+test: test-sbcl test-ccl test-ecl test-abcl
+
+test-sbcl:
+	$(heading_printer) computer 'SBCL'
+	sbcl --load test/run.lisp
+
+test-ccl:
+	$(heading_printer) slant 'CCL'
+	ccl --load test/run.lisp
+
+test-ecl:
+	$(heading_printer) roman 'ECL'
+	ecl -load test/run.lisp
+
+test-abcl:
+	$(heading_printer) broadway 'ABCL'
+	abcl --load test/run.lisp
diff -r 000000000000 -r 845fc8785d54 README.markdown
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/README.markdown	Wed Nov 21 23:22:18 2018 -0500
@@ -0,0 +1,15 @@
+Adopt
+=====
+
+I need **A** **D**amn **OPT**ion parsing library.
+
+
+Adopt is a simple (~200 LOC) UNIX-style option parser in Common Lisp.
+It depends on `bobbin` and `split-sequence`.
+
+It aims to be simple and powerful enough for the majority of use cases.
+
+* **License:** MIT
+* **Documentation:** <https://sjl.bitbucket.io/adopt/>
+* **Mercurial:** <https://bitbucket.org/sjl/adopt/>
+* **Git:** <https://github.com/sjl/adopt/>
diff -r 000000000000 -r 845fc8785d54 adopt.asd
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/adopt.asd	Wed Nov 21 23:22:18 2018 -0500
@@ -0,0 +1,34 @@
+(asdf:defsystem :adopt
+  :description "Simple, flexible UNIX-style option parsing."
+  :author "Steve Losh <steve@stevelosh.com>"
+  :homepage "https://sjl.bitbucket.io/adopt/"
+
+  :license "MIT"
+  :version "0.0.1"
+
+  :depends-on (:bobbin :split-sequence)
+
+  :in-order-to ((asdf:test-op (asdf:test-op :adopt/test)))
+
+  :serial t
+  :components ((:file "package")
+               (:module "src" :serial t
+                :components ((:file "main")))))
+
+
+(asdf:defsystem :adopt/test
+  :description "Test suite for adopt."
+
+  :author "Steve Losh <steve@stevelosh.com>"
+  :license "MIT"
+
+  :depends-on (:adopt :1am :losh)
+
+  :serial t
+  :components ((:file "package.test")
+               (:module "test"
+                :serial t
+                :components ((:file "tests"))))
+
+  :perform (asdf:test-op (op system)
+             (funcall (read-from-string "adopt.test:run-tests"))))
diff -r 000000000000 -r 845fc8785d54 package.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/package.lisp	Wed Nov 21 23:22:18 2018 -0500
@@ -0,0 +1,3 @@
+(defpackage :adopt
+  (:use :cl)
+  (:export :parse-options :print-usage :define-interface))
diff -r 000000000000 -r 845fc8785d54 package.test.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/package.test.lisp	Wed Nov 21 23:22:18 2018 -0500
@@ -0,0 +1,3 @@
+(defpackage :adopt.test
+  (:use :cl :1am :adopt)
+  (:export :run-tests))
diff -r 000000000000 -r 845fc8785d54 src/main.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/main.lisp	Wed Nov 21 23:22:18 2018 -0500
@@ -0,0 +1,282 @@
+(in-package :adopt)
+
+;;;; Utils --------------------------------------------------------------------
+(defun append1 (list el)
+  (append list (list el)))
+
+(defun latest (old new)
+  (declare (ignore old))
+  new)
+
+(defun argv ()
+  #+sbcl sb-ext:*posix-argv*
+  #+ccl ccl:*unprocessed-command-line-arguments*
+  #-(or sbcl ccl) (error "ARGV is not supported on this implementation."))
+
+
+;;;; 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%)))
+
+(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 documentation &key long short parameter initial-value reduce)
+  (make-instance 'option
+    :name name
+    :documentation documentation
+    :long long
+    :short short
+    :parameter parameter
+    :initial-value initial-value
+    :reduce reduce))
+
+
+(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)))
+
+(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)))))
+
+(defun make-interface (usage &rest options)
+  (let ((interface (make-instance 'interface
+                     :options nil
+                     :usage usage
+                     :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))))
+    (setf (options interface) (reverse (options interface)))
+    interface))
+
+(defmacro define-interface (name usage &rest options)
+  `(defparameter ,name
+     (make-interface ,usage
+                     ,@(loop :for (name . args) :in options :collect
+                             `(make-option ',name ,@args)))))
+
+
+;;;; Parsing ------------------------------------------------------------------
+(defun shortp (arg)
+  (and (> (length arg) 1)
+       (char= #\- (aref arg 0))
+       (char/= #\- (aref arg 1))))
+
+(defun longp (arg)
+  (and (> (length arg) 2)
+       (char= #\- (aref arg 0))
+       (char= #\- (aref arg 1))))
+
+(defun terminatorp (arg)
+  (string= "--" arg))
+
+
+(defun parse-long (interface results arg remaining)
+  (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))))
+  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)
+              (if (> (length arg) 2)
+                (push (format nil "-~A" (subseq arg 2)) remaining))))))
+  remaining)
+
+
+(defun parse-options (interface &optional (arguments (rest (argv))))
+  (let ((toplevel nil)
+        (results (make-hash-table)))
+    (dolist (option (options interface))
+      (setf (gethash (name% option) results) (initial-value% option)))
+    (labels
+        ((recur (arguments)
+           (if (null arguments)
+             (values (reverse toplevel) results)
+             (destructuring-bind (arg . remaining) arguments
+               (recur (cond
+                        ((terminatorp arg)
+                         (dolist (r remaining) (push r toplevel))
+                         nil)
+                        ((shortp arg)
+                         (parse-short interface results arg remaining))
+                        ((longp arg)
+                         (parse-long interface results arg remaining))
+                        (t (push arg toplevel) remaining)))))))
+      (recur arguments))))
+
+
+;;;; Printing Usage -----------------------------------------------------------
+(defun option-string (option)
+  (let* ((long (long% option))
+         (short (short% option))
+         (parameter (parameter% option))
+         (parameter-string (if parameter
+                             (format nil " ~A" parameter)
+                             "")))
+    (format nil "~{~A~^, ~}"
+            (remove nil
+                    (list (when short
+                            (format nil "-~A~A" short parameter-string))
+                          (when long
+                            (format nil "--~A~A" long parameter-string)))))))
+
+(defun print-option-usage (stream option option-column doc-column doc-width)
+  "Print `option` 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`.
+
+  "
+  (let ((option-string (option-string option))
+        (lines (bobbin:wrap (split-sequence:split-sequence
+                              #\newline (documentation% option))
+                            doc-width))
+        (col 0))
+    (flet ((print-at (c string &optional newline)
+             "Print `string` starting at column `c`, adding padding/newline if needed."
+             (when (> col c)
+               (terpri stream)
+               (setf col 0))
+             (format stream "~vA~A" (- c col) #\space string)
+             (if newline
+               (progn (terpri stream)
+                      (setf col 0))
+               (setf col (+ c (length string))))))
+      (print-at option-column option-string)
+      (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))
+  "Print a pretty usage 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
+  cases (extremely long short/long option names and parameters) may slip
+  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.
+
+  The result will look something like (assuming a usage string of
+  `\"[options] FILES\"`):
+
+    (print-usage *program-interface* :width 60 :option-width 15)
+    ; =>
+    USAGE: /bin/foo [options] FILES
+
+    Options:
+      -v, --verbose    Output extra information.
+      -q, --quiet      Shut up.
+      --ignore FILE    Ignore FILE.  May be specified multiple
+                       times.
+      -n NAME, --name NAME
+                       Your name.  May be specified many times,
+                       last one wins.
+      -m, --meow       Meow.
+
+      0.........10... option-width
+    0........10........20........30........40........50........60 width
+
+  "
+  (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))
+  (let* ((option-column 2)
+         (option-padding 2)
+         (doc-column (+ option-column option-width option-padding))
+         (doc-width (- width doc-column)))
+    (dolist (option (options interface))
+      (print-option-usage stream option option-column doc-column doc-width))))
+
+
+;;;; Scratch ------------------------------------------------------------------
+(define-interface *my-program* "[options] FILES"
+  (verbosity
+    "Output extra information."
+    :short #\v
+    :long "verbose"
+    :initial-value 0
+    :reduce (constantly 1))
+  (verbosity
+    "Shut up."
+    :short #\q
+    :long "quiet"
+    :reduce (constantly -1))
+  (ignore
+    "Ignore FILE.  May be specified multiple times."
+    :long "ignore"
+    :parameter "FILE"
+    :reduce #'append1)
+  (name
+    "Your name.  May be specified many times, last one wins."
+    :short #\n
+    :long "name"
+    :parameter "NAME"
+    :reduce #'latest)
+  (meows
+    "Meow."
+    :short #\m
+    :long "meow"
+    :initial-value 0
+    :reduce #'1+))
+
+(pprint
+  (multiple-value-list
+    (parse-options *my-program*
+                   '("-vqn" "steve"
+                     "--meow"
+                     "-m" "--meow" "foo"
+                     "--name=sjl" "more"
+                     "--" "--ignore" "bar"
+                     ))))
diff -r 000000000000 -r 845fc8785d54 test/run.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/test/run.lisp	Wed Nov 21 23:22:18 2018 -0500
@@ -0,0 +1,5 @@
+#+ecl (setf compiler:*user-cc-flags* "-Wno-shift-negative-value")
+
+(ql:quickload :adopt :silent t)
+(time (asdf:test-system :adopt))
+(quit)
diff -r 000000000000 -r 845fc8785d54 test/tests.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/test/tests.lisp	Wed Nov 21 23:22:18 2018 -0500
@@ -0,0 +1,200 @@
+(in-package :adopt.test)
+
+
+;;;; Utils --------------------------------------------------------------------
+(defmacro define-test (name &body body)
+  `(test ,(intern (concatenate 'string (symbol-name 'test-) (symbol-name name)))
+    (let ((*package* ,*package*))
+      ,@body)))
+
+
+(defun run-tests ()
+  (1am:run))
+
+
+(defun hash-table-equal (h1 h2)
+  (and (= (hash-table-count h1)
+          (hash-table-count h2))
+       (progn (maphash (lambda (k v)
+                         (unless (equal v (gethash k h2))
+                           (return-from hash-table-equal nil)))
+                       h1)
+              t)))
+
+(defun result (&rest key-value-pairs)
+  (loop :with result = (make-hash-table)
+        :for (k v) :on key-value-pairs :by #'cddr
+        :do (setf (gethash k result) v)
+        :finally (return result)))
+
+(defmacro check (interface input expected-args expected-result)
+  (let ((args (gensym "ARGS"))
+        (result (gensym "RESULT")))
+    `(multiple-value-bind (,args ,result)
+       (adopt:parse-options ,interface
+                            (split-sequence:split-sequence
+                              #\space ,input
+                              :remove-empty-subseqs t))
+       (is (equal ,expected-args ,args))
+       (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"
+  (short
+    "short-only"
+    :short #\s
+    :reduce (constantly t))
+  (long
+    "long-only"
+    :long "long"
+    :reduce (constantly t))
+  (both
+    "both short and long"
+    :short #\b
+    :long "both"
+    :reduce (constantly t)))
+
+(define-interface *reducers* "usage"
+  (c1
+    "constantly 1"
+    :short #\1
+    :reduce (constantly 1))
+  (c2
+    "constantly 2"
+    :short #\2
+    :reduce (constantly 2))
+  (snoc
+    "snoc"
+    :long "snoc"
+    :parameter "FOO"
+    :reduce (lambda (l el)
+              (cons el l))))
+
+(define-interface *same-name* "usage"
+  (x
+    "constantly 1"
+    :short #\1
+    :reduce (constantly 1))
+  (x
+    "constantly 2"
+    :short #\2
+    :reduce (constantly 2)))
+
+(define-interface *initial-value* "usage"
+  (foo
+    "foo"
+    :long "foo"
+    :initial-value "hello"
+    :reduce (constantly "goodbye")))
+
+(define-interface *parameters* "usage"
+  (no-param
+    "no parameter"
+    :long "no-param"
+    :initial-value 0
+    :reduce #'1+)
+  (param
+    "one parameter"
+    :long "param"
+    :parameter "P"
+    :reduce #'(lambda (old new) old new)))
+
+
+(define-test noop
+  (check *noop* ""
+         '()
+         (result))
+  (check *noop* "foo"
+         '("foo")
+         (result))
+  (check *noop* "a b c foo a"
+         '("a" "b" "c" "foo" "a")
+         (result)))
+
+(define-test option-types
+  (check *option-types* "foo -s bar"
+         '("foo" "bar")
+         (result 'short t
+                 'long nil
+                 'both nil))
+  (check *option-types* "foo --long bar"
+         '("foo" "bar")
+         (result 'short nil
+                 'long t
+                 'both nil))
+  (check *option-types* "foo --both bar"
+         '("foo" "bar")
+         (result 'short nil
+                 'long nil
+                 'both t))
+  (check *option-types* "foo -b bar"
+         '("foo" "bar")
+         (result 'short nil
+                 'long nil
+                 'both t))
+  (check *option-types* "foo -bs --long bar"
+         '("foo" "bar")
+         (result 'short t
+                 'long t
+                 'both t)))
+
+(define-test reducers
+  (check *reducers* ""
+         '()
+         (result 'c1 nil
+                 'c2 nil
+                 'snoc nil))
+  (check *reducers* "here we --snoc 1 --snoc 2 go -2 --snoc 3 -1"
+         '("here" "we" "go")
+         (result 'c1 1
+                 'c2 2
+                 'snoc '("3" "2" "1"))))
+
+(define-test same-name
+  (check *same-name* ""
+         '()
+         (result 'x nil))
+  (check *same-name* "-1"
+         '()
+         (result 'x 1))
+  (check *same-name* "-2"
+         '()
+         (result 'x 2))
+  (check *same-name* "-1121"
+         '()
+         (result 'x 1)))
+
+(define-test initial-value
+  (check *initial-value* ""
+         '()
+         (result 'foo "hello"))
+  (check *initial-value* "x"
+         '("x")
+         (result 'foo "hello"))
+  (check *initial-value* "x --foo y"
+         '("x" "y")
+         (result 'foo "goodbye")))
+
+(define-test parameters
+  (check *parameters* ""
+         '()
+         (result 'no-param 0
+                 'param nil))
+  (check *parameters* "--no-param foo"
+         '("foo")
+         (result 'no-param 1
+                 'param nil))
+  (check *parameters* "--param foo"
+         '()
+         (result 'no-param 0
+                 'param "foo"))
+  (check *parameters* "--no-param --param foo --no-param --param bar baz"
+         '("baz")
+         (result 'no-param 2
+                 'param "bar")))