diff --git a/README.md b/README.md index 299c042..5a1e4e3 100644 --- a/README.md +++ b/README.md @@ -20,6 +20,25 @@ In the `com.gfredericks.schpec` namespace: - `excl-keys`: like `s/keys`, but does not allow extra keys - `alias`: like `clojure.core/alias`, but can alias to non-existing namespaces +### `com.gfredericks.schpec.defn+spec/defn+spec` + +A variant of `defn` that allows annotating args with specs, and +overloading function clauses with specs. Tries each clause in order. + +E.g., + +``` clojure +(defn+spec thomas + ([a :- integer?, b :- boolean?] + [:int-and-bool a b]) + ([a b] + [:any-two-args a b]) + ([a b c :- integer? d & more] + [:four-args-1-int+varargs a b c d "here's the varargs ->" more]) + ([a b c d] + [:any-four-args a b c d])) +``` + ## Things it could have if it had them It is currently empty but is intended to be a home for all manner of diff --git a/src/com/gfredericks/schpec/defn+spec.clj b/src/com/gfredericks/schpec/defn+spec.clj new file mode 100644 index 0000000..72f9a92 --- /dev/null +++ b/src/com/gfredericks/schpec/defn+spec.clj @@ -0,0 +1,78 @@ +(ns com.gfredericks.schpec.defn+spec + (:refer-clojure :exclude [defn]) + (:require [clojure.core :as core] + [clojure.spec.alpha :as s])) + +(core/defn ^:private non-&-sym? [x] (and (symbol? x) (not= '& x))) + +(s/def ::arglist + (s/cat :normal-args (s/* (s/cat :name non-&-sym? + :spec-form (s/? (s/cat :- #{:-} + :spec any?)))) + :varargs (s/? (s/cat :& #{'&} + :name non-&-sym? + :spec-form (s/? (s/cat :- #{:-} + :spec any?)))))) + +(s/fdef kw->sym :args (s/cat :kw simple-keyword?) :ret simple-symbol?) +(core/defn ^:private kw->sym [kw] (symbol (str kw))) + +(core/defn ^:private parse-arglist + "Returns [spec-form destructuring-form]." + [{:keys [normal-args varargs]}] + (let [spec-form + `(s/cat ~@(mapcat (fn [{:keys [name], {:keys [spec] :as spec-provided?} :spec-form}] + (let [name-kw (keyword (str name))] + [name-kw (if spec-provided? + `(s/spec ~spec) + `(s/spec any?))])) + normal-args) + ~@(when varargs + [(-> varargs :name str keyword) + `(s/* ~(-> varargs :spec-form :spec (or any?)))])) + normal-arg-names (->> normal-args + (map :name) + (map kw->sym)) + destructuring-form (cond-> {:keys (vec normal-arg-names)} + varargs + (assoc (:name varargs) :more))] + [spec-form destructuring-form])) + +(s/def ::fntail (s/cat :arglist (s/spec ::arglist) + :body (s/* any?))) + +(s/def ::defn-args + (s/cat :name symbol? + :fntails + (s/alt + :unwrapped-fntail ::fntail + :wrapped-fntails (s/* (s/spec ::fntail)))) ) + +(s/fdef defn :args ::defn-args) +(defmacro defn + "A primitive variant of defn where args can be decorated with specs (via :-) + and there can be multiple bodies with the same arity, in which case the + first one for which the args match the specs is used." + [& args] + (let [{:keys [name fntails]} (s/conform ::defn-args args) + fntails (cond-> (second fntails) (= :unwrapped-fntail (first fntails)) list) + forms (map (comp parse-arglist :arglist) fntails) + impl-names (take (count fntails) (map #(keyword (str "clause-" %)) (range))) + or-spec `(s/or ~@(interleave impl-names (map first forms))) + conformed-name (gensym "conformed_")] + `(let [arglist-spec# ~or-spec] + (core/defn ~name + [& args#] + (let [~conformed-name (s/conform arglist-spec# args#)] + (if (= ::s/invalid ~conformed-name) + (throw (ex-info ~(str "Bad args to " name) + {:args args# + :explain (s/explain-data arglist-spec# args#)})) + (case (first ~conformed-name) + ~@(mapcat (fn [{:keys [body]} impl-name [_ destructuring-form]] + [impl-name + `(let [~destructuring-form (second ~conformed-name)] + ~@body)]) + fntails + impl-names + forms)))))))) diff --git a/test/com/gfredericks/schpec/defn+spec_test.clj b/test/com/gfredericks/schpec/defn+spec_test.clj new file mode 100644 index 0000000..34a34b2 --- /dev/null +++ b/test/com/gfredericks/schpec/defn+spec_test.clj @@ -0,0 +1,43 @@ +(ns com.gfredericks.schpec.defn+spec-test + (:require [clojure.spec.alpha :as s] + [clojure.test :refer [deftest is]] + [com.gfredericks.schpec.defn+spec :as defn+spec])) + +(defn+spec/defn single-body + [a :- integer? b] + [a b]) + +(deftest single-body-test + (is (= [42 49] (single-body 42 49))) + (is (= [0 "nil"] (single-body 0 "nil"))) + (is (thrown-with-msg? Exception #"Bad args to single-body" + (single-body 42))) + (is (thrown-with-msg? Exception #"Bad args to single-body" + (single-body "not a number" 42)))) + +(defn+spec/defn thomas + ([a :- integer?, b :- boolean?] + [:int-and-bool a b]) + ([a b] + [:any-two-args a b]) + ([a b c :- integer? d & more] + [:four-args-1-int+varargs a b c d "here's the varargs ->" more]) + ([a b c d] + [:any-four-args a b c d])) + +(defn+spec/defn my-identity + ([a] a)) + +(deftest defn+spec-test + (is (= 42 (my-identity 42))) + (is (= (thomas 1 2) + [:any-two-args 1 2])) + (is (= (thomas 42 true) + [:int-and-bool 42 true])) + (is (= (thomas "one" "two" "three" "four") + [:any-four-args "one" "two" "three" "four"])) + (is (= (thomas "one" "two" 3 "four" "five" "six") + [:four-args-1-int+varargs "one" "two" 3 "four" "here's the varargs ->" ["five" "six"]])) + + (is (thrown-with-msg? Exception #"Bad args to thomas" + (thomas 42)))) diff --git a/test/com/gfredericks/schpec_test.clj b/test/com/gfredericks/schpec_test.clj index f564af9..e54fe39 100644 --- a/test/com/gfredericks/schpec_test.clj +++ b/test/com/gfredericks/schpec_test.clj @@ -23,12 +23,12 @@ (is (s/valid? ::my-excl-keys sample)) (let [sample' (assoc sample ::some-other-key 1)] (is (= #:clojure.spec.alpha - {:problems [{:path [], - :pred '(clojure.core/fn [m] (clojure.set/subset? (clojure.core/set (clojure.core/keys m)) ks)), - :val sample', - :via [:com.gfredericks.schpec-test/my-excl-keys], :in []}] - :spec :com.gfredericks.schpec-test/my-excl-keys, - :value sample'} + {:problems [{:path [], + :pred '(clojure.core/fn [m] (clojure.set/subset? (clojure.core/set (clojure.core/keys m)) ks)), + :val sample', + :via [:com.gfredericks.schpec-test/my-excl-keys], :in []}] + :spec :com.gfredericks.schpec-test/my-excl-keys, + :value sample'} (s/explain-data ::my-excl-keys sample')))))) (s/def ::my-xor