--- /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
--- /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
--- /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.
--- /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
--- /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/>
--- /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"))))
--- /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))
--- /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))
--- /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"
+ ))))
--- /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)
--- /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")))