A defn-like macro powered by clojure.spec

defn+spec.clj

(ns user.defn+spec
  (:require [clojure.spec :as s]))

(defn 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 ::s/any))))
         :varargs (s/? (s/cat :& #{'&}
                              :name non-&-sym?
                              :spec-form (s/? (s/cat :- #{:-}
                                                     :spec ::s/any))))))

(s/fdef kw->sym :args (s/cat :kw simple-keyword?) :ret simple-symbol?)
(defn kw->sym [kw] (symbol (str kw)))

(s/fdef parse-arglist
        ::args (s/cat :arglist ::arglist)
        :ret (s/tuple ::s/any ::s/any))
(defn parse-arglist
  "Returns [spec-form destructuring-form]."
  [arglist]
  (let [{:keys [normal-args varargs]} (s/conform ::arglist arglist)
        spec-form
        `(s/cat ~@(mapcat (fn [{:keys [name], {:keys [spec]} :spec-form}]
                            (let [name-kw (keyword (str name))]
                              [name-kw `(s/spec ~spec)]))
                          normal-args)
                ~@(when varargs
                    [(-> varargs :name str keyword)
                     `(s/* ~(-> varargs :spec-form :spec (or ::s/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]))

;; commenting this out because I get a stack overflow otherwise
#_
(s/fdef defn+spec
        :args (s/cat :name symbol?
                     :fntails (s/* (s/cat :arglist ::arglist
                                          :body (s/* ::s/any)))))
(defmacro defn+spec
  "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."
  [name & fntails]
  (let [forms (map (comp parse-arglist first) 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]
       (defn ~name
         [& args#]
         (let [~conformed-name (s/conform arglist-spec# args#)]
           (if (= :clojure.spec/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 [[_ & body] impl-name [_ destructuring-form]]
                           [impl-name
                            `(let [~destructuring-form (second ~conformed-name)]
                               ~@body)])
                         fntails
                         impl-names
                         forms))))))))

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


(thomas 42)
;; throws "Bad args to thomas:
;; {:args (42),
;;  :explain
;;  {:clojure.spec/problems
;;   {[:clause-0 :b]
;;    {:in [],
;;     :pred (spec boolean?),
;;     :reason "Insufficient input",
;;     :val (),
;;     :via []},
;;    [:clause-1 :b]
;;    {:in [],
;;     :pred (spec nil),
;;     :reason "Insufficient input",
;;     :val (),
;;     :via []},
;;    [:clause-2 :b]
;;    {:in [],
;;     :pred (spec nil),
;;     :reason "Insufficient input",
;;     :val (),
;;     :via []},
;;    [:clause-3 :b]
;;    {:in [],
;;     :pred (spec nil),
;;     :reason "Insufficient input",
;;     :val (),
;;     :via []}}}}

(thomas 1 2) => [:any-two-args 1 2]
(thomas 42 true) => [:int-and-bool 42 true]
(thomas "one" "two" "three" "four") => [:any-four-args "one" "two" "three" "four"]
(thomas "one" "two" 3 "four" "five" "six") => [:four-args-1-int+varargs "one" "two" 3 "four" "here's the varargs ->" ["five" "six"]]

Wow

Thanks!