Add defn+spec

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

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))))))))

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))))

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