Permalink
Browse files

CLJS: Port compile-option-specs, parse-option-tokens

These functions ported smoothly, aside from a couple of interop
discrepancies.
  • Loading branch information...
1 parent 7997fcc commit 8e33c0a7e0561b574357fc70eb91e234d643f909 @guns guns committed Dec 9, 2013
Showing with 233 additions and 91 deletions.
  1. +138 −0 src/main/clojure/cljs/tools/cli.cljs
  2. +95 −91 src/test/clojure/clojure/tools/cli_test.clj
@@ -50,3 +50,141 @@
(recur opts (into argv (cons car cdr)) [])
(recur opts (conj argv car) cdr)))
[opts argv]))))
+
+(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
+ :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.
+
+ A :default entry will not be included in the compiled spec unless specified.
+
+ 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))
+
+(defn- default-option-map [specs]
+ (reduce (fn [m s]
+ (if (contains? s :default)
+ (assoc m (:id s) (:default s))
+ m))
+ {} specs))
+
+(defn- find-spec [specs opt-type opt]
+ (first (filter #(= opt (opt-type %)) specs)))
+
+(defn- pr-join [& xs]
+ (pr-str (s/join \space xs)))
+
+(defn- missing-required-error [opt example-required]
+ (str "Missing required argument for " (pr-join opt example-required)))
+
+(defn- parse-error [opt optarg msg]
+ (str "Error while parsing option " (pr-join opt optarg) ": " msg))
+
+(defn- validate-error [opt optarg msg]
+ (str "Failed to validate " (pr-join opt optarg)
+ (if msg (str ": " msg) "")))
+
+(defn- validate [value spec opt optarg]
+ (let [{:keys [validate-fn validate-msg]} spec]
+ (if (or (nil? validate-fn)
+ (try (validate-fn value) (catch js/Error _)))
+ [value nil]
+ [::error (validate-error opt optarg validate-msg)])))
+
+(defn- parse-value [value spec opt optarg]
+ (let [{:keys [parse-fn]} spec
+ [value error] (if parse-fn
+ (try
+ [(parse-fn value) nil]
+ (catch js/Error e
+ [nil (parse-error opt optarg (str e))]))
+ [value nil])]
+ (if error
+ [::error error]
+ (validate value spec opt optarg))))
+
+(defn- parse-optarg [spec opt optarg]
+ (let [{:keys [required]} spec]
+ (if (and required (nil? optarg))
+ [::error (missing-required-error opt required)]
+ (parse-value (if required optarg true) spec opt optarg))))
+
+(defn- parse-option-tokens
+ "Reduce sequence of [opt-type opt ?optarg?] tokens into a map of
+ {option-id value} merged over the default values in the option
+ specifications.
+
+ Unknown options, missing required arguments, option argument parsing
+ exceptions, and validation failures are collected into a vector of error
+ message strings.
+
+ Returns [option-map error-messages-vector]."
+ [specs tokens]
+ (reduce
+ (fn [[m errors] [opt-type opt optarg]]
+ (if-let [spec (find-spec specs opt-type opt)]
+ (let [[value error] (parse-optarg spec opt optarg)]
+ (if-not (= value ::error)
+ [((:assoc-fn spec assoc) m (:id spec) value) errors]
+ [m (conj errors error)]))
+ [m (conj errors (str "Unknown option: " (pr-str opt)))]))
+ [(default-option-map specs) []] tokens))
@@ -28,99 +28,103 @@
(is (= (tokenize-args #{} ["-a" "foo" "-b"] :in-order true)
[[[:short-opt "-a"]] ["foo" "-b"]]))))
-; (deftest test-compile-option-specs
-; (testing "does not set values for :default unless specified"
-; (is (= (map #(contains? % :default) (compile-option-specs
-; [["-f" "--foo"]
-; ["-b" "--bar=ARG" :default 0]]))
-; [false true])))
-; (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"}]))))
+(deftest test-compile-option-specs
+ (testing "does not set values for :default unless specified"
+ (is (= (map #(contains? % :default) (compile-option-specs
+ [["-f" "--foo"]
+ ["-b" "--bar=ARG" :default 0]]))
+ [false true])))
+ (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? ^:clj AssertionError #_(:cljs js/Error)
+ (compile-option-specs [["-a" :id nil]])))
+ (is (thrown? ^:clj AssertionError #_(:cljs js/Error)
+ (compile-option-specs [["-a" "--alpha"] ["-b" :id :alpha]])))
+ (is (thrown? ^:clj AssertionError #_(:cljs js/Error)
+ (compile-option-specs [{:id :a :short-opt "-a"} {:id :b :short-opt "-a"}])))
+ (is (thrown? ^:clj AssertionError #_(:cljs js/Error)
+ (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"}]))))
-; (defn has-error? [re coll]
-; (seq (filter (partial re-seq re) coll)))
+(defn has-error? [re coll]
+ (seq (filter (partial re-seq re) coll)))
-; (deftest test-parse-option-tokens
-; (testing "parses and validates option arguments"
-; (let [specs (compile-option-specs
-; [["-p" "--port NUMBER"
-; :parse-fn #(Integer/parseInt %)
-; :validate [#(< 0 % 0x10000) "Must be between 0 and 65536"]]
-; ["-f" "--file PATH"
-; :validate [#(not= \/ (first %)) "Must be a relative path"]]
-; ["-q" "--quiet"
-; :id :verbose
-; :default true
-; :parse-fn not]])]
-; (is (= (parse-option-tokens specs [[:long-opt "--port" "80"] [:short-opt "-q"]])
-; [{:port (int 80) :verbose false} []]))
-; (is (has-error? #"Unknown option"
-; (peek (parse-option-tokens specs [[:long-opt "--unrecognized"]]))))
-; (is (has-error? #"Missing required"
-; (peek (parse-option-tokens specs [[:long-opt "--port"]]))))
-; (is (has-error? #"Must be between"
-; (peek (parse-option-tokens specs [[:long-opt "--port" "0"]]))))
-; (is (has-error? #"Error while parsing"
-; (peek (parse-option-tokens specs [[:long-opt "--port" "FOO"]]))))
-; (is (has-error? #"Must be a relative path"
-; (peek (parse-option-tokens specs [[:long-opt "--file" "/foo"]]))))))
-; (testing "merges values over default option map"
-; (let [specs (compile-option-specs
-; [["-a" "--alpha"]
-; ["-b" "--beta" :default false]
-; ["-g" "--gamma=ARG"]
-; ["-d" "--delta=ARG" :default "DELTA"]])]
-; (is (= (parse-option-tokens specs [])
-; [{:beta false :delta "DELTA"} []]))
-; (is (= (parse-option-tokens specs [[:short-opt "-a"]
-; [:short-opt "-b"]
-; [:short-opt "-g" "GAMMA"]
-; [:short-opt "-d" "delta"]])
-; [{:alpha true :beta true :gamma "GAMMA" :delta "delta"} []]))))
-; (testing "associates :id and value with :assoc-fn"
-; (let [specs (compile-option-specs
-; [["-a" "--alpha"
-; :default true
-; :assoc-fn (fn [m k v] (assoc m k (not v)))]
-; ["-v" "--verbose"
-; :default 0
-; :assoc-fn (fn [m k _] (assoc m k (inc (m k))))]])]
-; (is (= (parse-option-tokens specs [])
-; [{:alpha true :verbose 0} []]))
-; (is (= (parse-option-tokens specs [[:short-opt "-a"]])
-; [{:alpha false :verbose 0} []]))
-; (is (= (parse-option-tokens specs [[:short-opt "-v"]
-; [:short-opt "-v"]
-; [:long-opt "--verbose"]])
-; [{:alpha true :verbose 3} []])))))
+(deftest test-parse-option-tokens
+ (testing "parses and validates option arguments"
+ (let [specs (compile-option-specs
+ [["-p" "--port NUMBER"
+ :parse-fn (fn [x]
+ ^:clj (Integer/parseInt x)
+ #_(:cljs (do (assert (re-seq #"^\d" x)) (js/parseInt x))))
+ :validate [#(< 0 % 0x10000) "Must be between 0 and 65536"]]
+ ["-f" "--file PATH"
+ :validate [#(not= \/ (first %)) "Must be a relative path"]]
+ ["-q" "--quiet"
+ :id :verbose
+ :default true
+ :parse-fn not]])]
+ (is (= (parse-option-tokens specs [[:long-opt "--port" "80"] [:short-opt "-q"]])
+ [{:port (int 80) :verbose false} []]))
+ (is (has-error? #"Unknown option"
+ (peek (parse-option-tokens specs [[:long-opt "--unrecognized"]]))))
+ (is (has-error? #"Missing required"
+ (peek (parse-option-tokens specs [[:long-opt "--port"]]))))
+ (is (has-error? #"Must be between"
+ (peek (parse-option-tokens specs [[:long-opt "--port" "0"]]))))
+ (is (has-error? #"Error while parsing"
+ (peek (parse-option-tokens specs [[:long-opt "--port" "FOO"]]))))
+ (is (has-error? #"Must be a relative path"
+ (peek (parse-option-tokens specs [[:long-opt "--file" "/foo"]]))))))
+ (testing "merges values over default option map"
+ (let [specs (compile-option-specs
+ [["-a" "--alpha"]
+ ["-b" "--beta" :default false]
+ ["-g" "--gamma=ARG"]
+ ["-d" "--delta=ARG" :default "DELTA"]])]
+ (is (= (parse-option-tokens specs [])
+ [{:beta false :delta "DELTA"} []]))
+ (is (= (parse-option-tokens specs [[:short-opt "-a"]
+ [:short-opt "-b"]
+ [:short-opt "-g" "GAMMA"]
+ [:short-opt "-d" "delta"]])
+ [{:alpha true :beta true :gamma "GAMMA" :delta "delta"} []]))))
+ (testing "associates :id and value with :assoc-fn"
+ (let [specs (compile-option-specs
+ [["-a" "--alpha"
+ :default true
+ :assoc-fn (fn [m k v] (assoc m k (not v)))]
+ ["-v" "--verbose"
+ :default 0
+ :assoc-fn (fn [m k _] (assoc m k (inc (m k))))]])]
+ (is (= (parse-option-tokens specs [])
+ [{:alpha true :verbose 0} []]))
+ (is (= (parse-option-tokens specs [[:short-opt "-a"]])
+ [{:alpha false :verbose 0} []]))
+ (is (= (parse-option-tokens specs [[:short-opt "-v"]
+ [:short-opt "-v"]
+ [:long-opt "--verbose"]])
+ [{:alpha true :verbose 3} []])))))
; (deftest test-summarize
; (testing "summarizes options"

0 comments on commit 8e33c0a

Please sign in to comment.