Add cli/compile-option-specs

Compiled option specifications are a vector of:

{:id           Keyword  ; :server
 :short-opt    String   ; \"-s\"
 :long-opt     String   ; \"--server\"
 :required     String   ; \"HOSTNAME\"
 :desc         String   ; \"Remote server\"
 :default      Object   ; #<Inet4Address example.com/93.184.216.119>
 :default-desc String   ; \"example.com\"
 :parse-fn     IFn      ; #(InetAddress/getByName %)
 :assoc-fn     IFn      ; assoc
 :validate-fn  IFn      ; (partial instance? Inet4Address)
 :validate-msg String   ; \"%s is not an IPv4 host\"
 }

The vector option spec format is desugared into the map above. All
entries are overridable, allowing for fine control of the resulting
option map after parsing an args sequence.

Additions from cli/cli include:

    :default-desc   A string that is used to represent the default
                    value, in case the string representation of the
                    default is too ugly to be printed in help output.

    :required       All options are considered boolean flags by default,
                    unless this value is truthy. The value if present
                    should be a string that will be printed as an
                    example required argument to the option.

    :validate-fn    Validates required option arguments *after* being
                    parsed by parse-fn. Exceptions are caught and return
                    nil.

    :validate-msg   If validate-fn returns a falsy value, validate-msg
                    is conjed onto the parse-opts :errors vector.

cli/compile-option-specs asserts the presence of an :id value in every
map, as well as the uniqueness of all :id, :short-opt, and :long-opt
values.

src/main/clojure/clojure/tools/cli.clj

@@ -205,3 +205,78 @@
     (let [[options extra-args] (apply-specs specs args)
           banner  (with-out-str (banner-for desc specs))]
       [options extra-args banner])))
+
+;;
+;; New API
+;;
+
+(def ^{:private true} spec-keys
+  [:id :short-opt :long-opt :required :desc :default :default-desc :parse-fn
+   :assoc-fn :validate-fn :validate-msg])
+
+(defn- compile-spec [spec]
+  (let [sopt-lopt-desc (take-while #(or (string? %) (nil? %)) spec)
+        spec-map (apply hash-map (drop (count sopt-lopt-desc) spec))
+        [short-opt long-opt desc] sopt-lopt-desc
+        long-opt (or long-opt (:long-opt spec-map))
+        [long-opt req] (when long-opt
+                         (rest (re-find #"^(--[^ =]+)(?:[ =](.*))?" long-opt)))
+        id (when long-opt
+             (keyword (subs long-opt 2)))
+        [validate-fn validate-msg] (:validate spec-map)]
+    (merge {:id id
+            :short-opt short-opt
+            :long-opt long-opt
+            :required req
+            :desc desc
+            :default nil
+            :default-desc nil
+            :parse-fn nil
+            :assoc-fn nil
+            :validate-fn validate-fn
+            :validate-msg validate-msg}
+           (select-keys spec-map spec-keys))))
+
+(defn- distinct?* [coll]
+  (if (seq coll)
+    (apply distinct? coll)
+    true))
+
+(defn- compile-option-specs
+  "Map a sequence of option specification vectors to a sequence of:
+
+  {:id           Keyword  ; :server
+   :short-opt    String   ; \"-s\"
+   :long-opt     String   ; \"--server\"
+   :required     String   ; \"HOSTNAME\"
+   :desc         String   ; \"Remote server\"
+   :default      Object   ; #<Inet4Address example.com/93.184.216.119>
+   :default-desc String   ; \"example.com\"
+   :parse-fn     IFn      ; #(InetAddress/getByName %)
+   :assoc-fn     IFn      ; assoc
+   :validate-fn  IFn      ; (partial instance? Inet4Address)
+   :validate-msg String   ; \"Must be an IPv4 host\"
+   }
+
+  :id defaults to the keywordized name of long-opt without leading dashes, but
+  may be overridden in the option spec.
+
+  The option spec entry `:validate [fn msg]` desugars into the two entries
+  :validate-fn and :validate-msg.
+
+  An option spec may also be passed as a map containing the entries above,
+  in which case that subset of the map is transferred directly to the result
+  vector.
+
+  An assertion error is thrown if any :id values are unset, or if there exist
+  any duplicate :id, :short-opt, or :long-opt values."
+  [specs]
+  {:post [(every? (comp identity :id) %)
+          (distinct?* (map :id %))
+          (distinct?* (remove nil? (map :short-opt %)))
+          (distinct?* (remove nil? (map :long-opt %)))]}
+  (map (fn [spec]
+         (if (map? spec)
+           (select-keys spec spec-keys)
+           (compile-spec spec)))
+       specs))

src/test/clojure/clojure/tools/cli_test.clj

@@ -177,3 +177,41 @@
               "--" "--full" "stop"])
            ["-a" "-x" "ray" "-b" "-y" "yankee" "-c" "--zulu" "zebra"
             "foo" "bar" "baz" "--" "--full" "stop"]))))
+
+(def compile-option-specs
+  #'cli/compile-option-specs)
+
+(deftest test-compile-option-specs
+  (testing "returns values for all keys in spec-keys"
+    (is (= (set (keys (first (compile-option-specs [["-f" "--foo" "desc"]]))))
+           (set @#'cli/spec-keys))))
+  (testing "interprets first three string arguments as short-opt, long-opt=required, and desc"
+    (is (= (map (juxt :short-opt :long-opt :required :desc)
+                (compile-option-specs [["-a" :id :alpha]
+                                       ["-b" "--beta"]
+                                       [nil nil "DESC" :id :gamma]
+                                       ["-f" "--foo=FOO" "desc"]]))
+           [["-a" nil nil nil]
+            ["-b" "--beta" nil nil]
+            [nil nil nil "DESC"]
+            ["-f" "--foo" "FOO" "desc"]])))
+  (testing "throws AssertionError on unset :id or duplicate :id, :short-opt, :long-opt"
+    (is (thrown? AssertionError (compile-option-specs [["-a" :id nil]])))
+    (is (thrown? AssertionError (compile-option-specs [["-a" "--alpha"] ["-b" :id :alpha]])))
+    (is (thrown? AssertionError (compile-option-specs [{:id :a :short-opt "-a"}
+                                                       {:id :b :short-opt "-a"}])))
+    (is (thrown? AssertionError (compile-option-specs [{:id :alpha :long-opt "--alpha"}
+                                                       {:id :beta :long-opt "--alpha"}]))))
+  (testing "desugars `--long-opt=value`"
+    (is (= (map (juxt :id :long-opt :required)
+                (compile-option-specs [[nil "--foo FOO"] [nil "--bar=BAR"]]))
+           [[:foo "--foo" "FOO"]
+            [:bar "--bar" "BAR"]])))
+  (testing "desugars :validate [fn msg]"
+    (is (= (map (juxt :validate-fn :validate-msg)
+                (compile-option-specs
+                  [[nil "--name NAME" :validate [seq "Must be present"]]]))
+           [[seq "Must be present"]])))
+  (testing "accepts maps as option specs without munging values"
+    (is (= (compile-option-specs [{:id ::foo :short-opt "-f" :long-opt "--foo" :bad-key nil}])
+           [{:id ::foo :short-opt "-f" :long-opt "--foo"}]))))