spec.clj

(ns clojure.spec.test.alpha
  (:refer-clojure :exclude [test])
  (:require
   [clojure.pprint :as pp]
   [clojure.spec.alpha :as s]
   [clojure.spec.gen.alpha :as gen]
   [clojure.string :as str]))

(in-ns 'clojure.spec.test.check)
(in-ns 'clojure.spec.test.alpha)
(alias 'stc 'clojure.spec.test.check)

(defn- throwable?
  [x]
  (instance? Throwable x))

(defn ->sym
  [x]
  (@#'s/->sym x))

(defn- ->var
  [s-or-v]
  (if (var? s-or-v)
    s-or-v
    (let [v (and (symbol? s-or-v) (resolve s-or-v))]
      (if (var? v)
        v
        (throw (IllegalArgumentException. (str (pr-str s-or-v) " does not name a var")))))))

(defn- collectionize
  [x]
  (if (symbol? x)
    (list x)
    x))

(defn enumerate-namespace
  "Given a symbol naming an ns, or a collection of such symbols,
returns the set of all symbols naming vars in those nses."
  [ns-sym-or-syms]
  (into
   #{}
   (mapcat (fn [ns-sym]
             (map
              (fn [name-sym]
                (symbol (name ns-sym) (name name-sym)))
              (keys (ns-interns ns-sym)))))
   (collectionize ns-sym-or-syms)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; instrument ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(def ^:private ^:dynamic *instrument-enabled*
  "if false, instrumented fns call straight through"
  true)

(defn- fn-spec?
  "Fn-spec must include at least :args or :ret specs."
  [m]
  (or (:args m) (:ret m)))

(defmacro with-instrument-disabled
  "Disables instrument's checking of calls, within a scope."
  [& body]
  `(binding [*instrument-enabled* nil]
     ~@body))

(defn- interpret-stack-trace-element
  "Given the vector-of-syms form of a stacktrace element produced
by e.g. Throwable->map, returns a map form that adds some keys
guessing the original Clojure names. Returns a map with

  :class         class name symbol from stack trace
  :method        method symbol from stack trace
  :file          filename from stack trace
  :line          line number from stack trace
  :var-scope     optional Clojure var symbol scoping fn def
  :local-fn      optional local Clojure symbol scoping fn def

For non-Clojure fns, :scope and :local-fn will be absent."
  [[cls method file line]]
  (let [clojure? (contains? '#{invoke invokeStatic} method)
        demunge #(clojure.lang.Compiler/demunge %)
        degensym #(str/replace % #"--.*" "")
        [ns-sym name-sym local] (when clojure?
                                  (->> (str/split (str cls) #"\$" 3)
                                       (map demunge)))]
    (merge {:file file
            :line line
            :method method
            :class cls}
           (when (and ns-sym name-sym)
             {:var-scope (symbol ns-sym name-sym)})
           (when local
             {:local-fn (symbol (degensym local))}))))

(defn- stacktrace-relevant-to-instrument
  "Takes a coll of stack trace elements (as returned by
StackTraceElement->vec) and returns a coll of maps as per
interpret-stack-trace-element that are relevant to a
failure in instrument."
  [elems]
  (let [plumbing? (fn [{:keys [var-scope]}]
                    (contains? '#{clojure.spec.test.alpha/spec-checking-fn} var-scope))]
    (sequence (comp (map StackTraceElement->vec)
                    (map interpret-stack-trace-element)
                    (filter :var-scope)
                    (drop-while plumbing?))
              elems)))

(defn- spec-checking-fn
  [v f fn-spec]
  (let [fn-spec (@#'s/maybe-spec fn-spec)
        conform! (fn [v 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 (->sym v)
                                         ::s/args args
                                         ::s/failure :instrument)
                                       (when caller
                                         {::caller (dissoc caller :class :method)}))]
                         (throw (ex-info
                                 (str "Call to " v " did not conform to spec.")
                                 ed)))
                       conformed)))]
    (fn
     [& args]
     (if *instrument-enabled*
       (with-instrument-disabled
         (when (:args fn-spec) (conform! v :args (:args fn-spec) args args))
         (binding [*instrument-enabled* true]
           (.applyTo ^clojure.lang.IFn f args)))
       (.applyTo ^clojure.lang.IFn f args)))))

(defn- no-fspec
  [v spec]
  (ex-info (str "Fn at " v " is not spec'ed.")
           {:var v :spec spec ::s/failure :no-fspec}))

(defonce ^:private instrumented-vars (atom {}))

(defn- find-varargs-decl
  "Inspects a arglist to find a varargs declarator, i.e. the element after
  the ampersand, and returns it if found."
  [arglist]
  (let [[_ decl :as restargs] (->> arglist
                                   (split-with (complement #{'&}))
                                   second)]
    (and (= 2 (count restargs))
         decl)))

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

(defn- build-xform [local]
  `(if (even? (count ~local))
     ~local
     (concat (butlast ~local)
             (reduce-kv (fn [acc# k# v#] (->> acc# (cons v#) (cons k#)))
                        ()
                        (last ~local)))))

(defn- process-fixed-args
  "Takes an arglist and returns a vector of symbols pertaining to the
  fixed arguments in the original arglist."
  [arglist]
  (->> arglist (take-while (complement #{'&})) (map (fn [_] (gensym))) vec))

(defn- kwargs-body
  "Builds a function body pertaining to a keyword arguments arity.
  A varargs arity is built with a processing chain for the
  incoming arguments that detects if a trailing argument exists and
  attempts to convert it to a seq of key->val pairs. This seq is the
  input to the underlying function prefixed by any named arguments."
  [f arglist]
  (let [alias (gensym "kvs")
        head-args (process-fixed-args arglist)]
    (list (conj head-args '& alias)
          `(apply ~f ~@head-args ~(build-xform alias)))))

(defn- varargs-body
  "Builds a function body pertaining to a varargs arity. Builds the
  call to the underlying function by supplying any named parameters
  and the varargs parameter to apply."
  [f arglist]
  (let [head-args (process-fixed-args arglist)
        alias  (gensym "args")]
    (list (conj head-args '& alias)
          `(apply ~f ~@head-args ~alias))))

(defn- fixed-args-body
  "Builds an argument context for fixed arities. The arguments
  are taken directly from the parameter list."
  [f arglist]
  (let [arglist (process-fixed-args arglist)]
    (list arglist
          `(~f ~@arglist))))

(defn- gen-bodies
  "Generates the function bodies corresponding to the arities found in the
  :arglists meta of the Var v. Takes an additional name pertaining to 
  an underlying function to capture and delegate to in the function bodies."
  [v closed-over-name]
  (map (fn [arglist]
         (let [varargs-decl (find-varargs-decl arglist)]
           (cond (map? varargs-decl) (kwargs-body     closed-over-name arglist)
                 varargs-decl        (varargs-body    closed-over-name arglist)
                 :default            (fixed-args-body closed-over-name arglist))))
       (or (->> v meta :arglists (sort-by count) seq)
           '([& args]))))

(defn- gen-thunk
  "Builds a thunk and its lexical environment used to instrument a function
  and perform Spec checking at runtime."
  [v]
  (let [lexical-name (gensym "inner")]
    `(fn [~lexical-name]
       (fn
         ~@(gen-bodies v lexical-name)))))

(comment
  ;; The thunk 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))
                                kvs
                                (reduce-kv (fn [acc k v]
                                             (->> acc (cons v) (cons k)))
                                                     (butlast G__kvs)
                                                     (last G__kvs)))))))
)

(defn- instrument-choose-fn
  "Helper for instrument."
  [f spec sym {over :gen :keys [stub replace]}]
  (if (some #{sym} stub)
    (-> spec (s/gen over) gen/generate)
    (get replace sym f)))

(defn- instrument-choose-spec
  "Helper for instrument"
  [spec sym {overrides :spec}]
  (get overrides sym spec))

(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 v ofn ospec)
            wrapped (if (has-kwargs? v)
                      (let [thunk (eval (gen-thunk v))] (thunk checked))
                      checked)]
        (alter-var-root v (constantly wrapped))
        (swap! instrumented-vars assoc v {:raw to-wrap :wrapped wrapped})
        (->sym v)))))