spec-moar.clj

(defn- spec-checking-fn
  "Takes a function name, a function f, and an fspec and returns a thunk that
  first conforms the arguments given then calls f with those arguments if
  the conform succeeds. Otherwise, an exception is thrown containing information
  about the conform failure."
  [fn-name f fn-spec]
  (let [fn-spec (@#'s/maybe-spec fn-spec)
        conform! (fn [fn-name role spec data args]
                   (let [conformed (s/conform spec data)]
                     (if (= ::s/invalid conformed)
                       (let [caller (->> (.getStackTrace (Thread/currentThread))
                                         stacktrace-relevant-to-instrument
                                         first)
                             ed (merge (assoc (s/explain-data* spec [] [] [] data)
                                         ::s/fn fn-name
                                         ::s/args args
                                         ::s/failure :instrument)
                                       (when caller
                                         {::caller (dissoc caller :class :method)}))]
                         (throw (ex-info
                                 (str "Call to " fn-name " did not conform to spec.")
                                 ed)))
                       conformed)))]
    (fn
     [& args]
     (if *instrument-enabled*
       (with-instrument-disabled
         (when (:args fn-spec) (conform! fn-name :args (:args fn-spec) args args))
         (binding [*instrument-enabled* true]
           (.applyTo ^clojure.lang.IFn f args)))
       (.applyTo ^clojure.lang.IFn f args)))))

(defn- find-varargs-decl
  "Takes an arglist and returns the restargs binding form if found, else nil."
  [arglist]
  (let [[_ decl :as restargs] (->> arglist
                                   (split-with (complement #{'&}))
                                   second)]
    (and (= 2 (count restargs))
         decl)))

(defn- has-kwargs? [arglists]
  (->> arglists (some find-varargs-decl) map?))

(defn- kwargs->kvs
  "Takes the restargs of a kwargs function call and checks for a trailing element.
  If found, that element is flattened into a sequence of key->value pairs and
  concatenated onto the preceding arguments."
  [args]
  (if (even? (count args))
     args
     (concat (butlast args)
             (reduce-kv (fn [acc k v] (->> acc (cons v) (cons k)))
                        ()
                        (last args)))))

(defn- gen-fixed-args-syms
  "Takes an arglist and generates a vector of names corresponding to the fixed
  args found."
  [arglist]
  (->> arglist (take-while (complement #{'&})) (map (fn [_] (gensym))) vec))

(defn- build-kwargs-body
  "Takes a function name fn-name and arglist and returns code for a function body that
  handles kwargs by calling fn-name with any fixed followed by its restargs transformed
  from kwargs to kvs."
  [fn-name arglist]
  (let [alias (gensym "kwargs")
        head-args (gen-fixed-args-syms arglist)]
    (list (conj head-args '& alias)
          `(apply ~fn-name ~@head-args (@#'kwargs->kvs ~alias)))))

(defn- build-varargs-body
  "Takes a function name fn-name and arglist and returns code for a function body that
  handles varargs by calling fn-name with any fixed args followed by its rest args."
  [fn-name arglist]
  (let [head-args (gen-fixed-args-syms arglist)
	alias  (gensym "restargs")]
    (list (conj head-args '& alias)
          `(apply ~fn-name ~@head-args ~alias))))

(defn- build-fixed-args-body
  "Takes a function name fn-name and arglist and returns code for a function body that
  handles fixed args by calling fn-name with its fixed args."
  [fn-name arglist]
  (let [arglist (gen-fixed-args-syms arglist)]
    (list arglist
          `(~fn-name ~@arglist))))

(defn- build-flattener-code
  "Takes argslists and generates code for a HOF that given a function, returns a forwarding thunk
  of analogous arglists that ensures that kwargs are passed as kvs to the original function."
  [arglists]
  (let [closed-over-name (gensym "inner")]
    `(fn [~closed-over-name]
       (fn ~@(map (fn [arglist]
                    (let [varargs-decl (find-varargs-decl arglist)]
                      (cond (map? varargs-decl) (build-kwargs-body     closed-over-name arglist)
                            varargs-decl        (build-varargs-body    closed-over-name arglist)
                            :default            (build-fixed-args-body closed-over-name arglist))))
                  (or arglists
                      '([& args])))))))

(comment
  ;; Given a function with the arglists (([a]) ([a b]) ([a b & kvs]))
  ;; the flattener generated is below (with some gensym name cleanup for readability)
  (fn [inner]
    (fn
      ([G__a] (inner G__a))
      ([G__a G__b] (inner G__a G__b))
      ([G__a G__b & G__kvs]
       (apply inner G__a G__b (if (even? (count G__kvs))
                                G__kvs
                                (reduce-kv (fn [acc k v]
                                             (->> acc (cons v) (cons k)))
                                                  (butlast G__kvs)
                                                  (last G__kvs)))))))
)

(defn- maybe-wrap-kvs-emulation
  "Takes an argslist and function f and returns f except when arglists
  contains a kwargs binding, else wraps f with a forwarding thunk that
  flattens a trailing map into kvs if present in the kwargs call."
  [f arglists]
  (if (has-kwargs? arglists)
    (let [flattener-code (build-flattener-code arglists)
          kvs-emu (eval flattener-code)]
      (kvs-emu f))
    f))

(defn- instrument-1
  [s opts]
  (when-let [v (resolve s)]
    (when-not (-> v meta :macro)
      (let [spec (s/get-spec v)
            {:keys [raw wrapped]} (get @instrumented-vars v)
            current @v
            to-wrap (if (= wrapped current) raw current)
            ospec (or (instrument-choose-spec spec s opts)
                      (throw (no-fspec v spec)))
            ofn (instrument-choose-fn to-wrap ospec s opts)
            checked (spec-checking-fn (->sym v) ofn ospec)
            arglists (->> v meta :arglists (sort-by count) seq)
            wrapped (maybe-wrap-kvs-emulation checked arglists)]
        (alter-var-root v (constantly wrapped))
        (swap! instrumented-vars assoc v {:raw to-wrap :wrapped wrapped})
        (->sym v)))))

• 45: unmappify - maybe this could be flatten-trailing-map ?
• 47: "convert" does not say anything - s/converted/flattened/
• 57: "process" does not say anything - I think you are really creating new unique names for each fixed arg in an arglist so maybe name-fixed-args would be more descriptive? And the reason to do this (destructuring in original arglist) is implicit but I don't think is actually mentioned anywhere. would be great to leave that clue in here somewhere.
• 63-92: on all these the docstrings say "Takes a function ..." but I think "Takes a function name ..." is more accurate and useful to me
• 63-92: on all these, the combination of list/conj style and backtick style throws me off, all one or the other would be easier to read
• 102-106: maybe the anonymous inner "make a f body" should be an explicit function and could actually absorb all the impls of the build-*-body fns. seems like you might even be able to condense to one canonical wrapper body that covered the cases and end up with a lot less code and a single docstring. happy to pair on that refactoring if useful.
• 111: I think this comment would be even more helpful if it started with, "given a function with the arglists (([a]) ([a b]) ([a b & kvs])) ..."
• 118: should be G__kvs, not kvs