# HG changeset patch # User Steve Losh # Date 1542860538 18000 # Node ID 845fc8785d54b088b019eb212f8a0743e85bcadf Initial commit 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:** +* **Mercurial:** +* **Git:** 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 " + :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 " + :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")))