instrumentation

src/sci/configs/cljs/spec/alpha.cljs

@@ -2,10 +2,12 @@
   (:refer-clojure :exclude [and or keys merge every cat + ? * assert])
   (:require [clojure.spec.alpha :as s]
             [cljs.spec.gen.alpha :as gen]
+            [cljs.spec.test.alpha :as stest]
             [sci.core :as sci]
             [sci.ctx-store :as ctx]
             [clojure.walk :as walk]
             [clojure.core :as c]
+            [clojure.string :as str]
             [sci.lang])
   (:require-macros [sci.configs.macros :as macros]))
 
@@ -14,6 +16,9 @@
 (defonce ^:private registry-ref (atom {}))
 (defonce ^:private _speced_vars (atom #{}))
 
+(defn speced-vars []
+  @_speced_vars)
+
 (defn- unfn [expr]
   (if (clojure.core/and (seq? expr)
                         (symbol? (first expr))
@@ -486,6 +491,151 @@
   `(s/spec (s/and c/int? #(s/int-in-range? ~start ~end %))
            :gen #(gen/large-integer* {:min ~start :max (dec ~end)})))
 
+(def tns (sci/create-ns 'cljs.spec.test.alpha))
+
+(defn- collectionize
+  [x]
+  (if (symbol? x)
+    (list x)
+    x))
+
+(defn- sym-or-syms->syms [sym-or-syms]
+  (into []
+        (mapcat
+         (fn [sym]
+           (if (c/and (str/includes? (str sym) ".")
+                      (sci/find-ns (ctx/get-ctx) sym))
+             (let [ni (sci/eval-form (ctx/get-ctx) `(ns-interns '~sym))]
+               (->> (vals ni)
+                    (map meta)
+                    (filter #(not (:macro %)))
+                    (map :name)
+                    (map
+                     (fn [name-sym]
+                       (symbol (name sym) (name name-sym))))))
+             [sym])))
+        (collectionize sym-or-syms)))
+
+(defn- form->sym-or-syms
+  "Helper for extracting a symbol or symbols from a (potentially
+  user-supplied) quoted form. In the case that the form has ::no-eval meta, we
+  know it was generated by us and we directly extract the result, assuming the
+  shape of the form. This avoids applying eval to extremely large forms in the
+  latter case."
+  [sym-or-syms]
+  (if (::no-eval (meta sym-or-syms))
+    (second sym-or-syms)
+    (eval sym-or-syms)))
+
+
+(macros/defmacro instrument
+  "Instruments the vars named by sym-or-syms, a symbol or collection
+of symbols, or all instrumentable vars if sym-or-syms is not
+specified. If a symbol identifies a namespace then all symbols in that
+namespace will be enumerated.
+
+If a var has an :args fn-spec, sets the var's root binding to a
+fn that checks arg conformance (throwing an exception on failure)
+before delegating to the original fn.
+
+The opts map can be used to override registered specs, and/or to
+replace fn implementations entirely. Opts for symbols not included
+in sym-or-syms are ignored. This facilitates sharing a common
+options map across many different calls to instrument.
+
+The opts map may have the following keys:
+
+  :spec     a map from var-name symbols to override specs
+  :stub     a set of var-name symbols to be replaced by stubs
+  :gen      a map from spec names to generator overrides
+  :replace  a map from var-name symbols to replacement fns
+
+:spec overrides registered fn-specs with specs your provide. Use
+:spec overrides to provide specs for libraries that do not have
+them, or to constrain your own use of a fn to a subset of its
+spec'ed contract.
+
+:stub replaces a fn with a stub that checks :args, then uses the
+:ret spec to generate a return value.
+
+:gen overrides are used only for :stub generation.
+
+:replace replaces a fn with a fn that checks args conformance, then
+invokes the fn you provide, enabling arbitrary stubbing and mocking.
+
+:spec can be used in combination with :stub or :replace.
+
+Returns a collection of syms naming the vars instrumented."
+  ([]
+   (let [s (speced-vars)]
+     `(stest/instrument ~(with-meta (list 'quote s)
+                           {::no-eval true}))))
+  ([xs]
+   `(stest/instrument ~xs nil))
+  ([sym-or-syms opts]
+   (let [syms (sym-or-syms->syms (form->sym-or-syms sym-or-syms))
+         opts-sym (gensym "opts")]
+     `(let [~opts-sym ~opts]
+        (reduce
+          (fn [ret# [_# f#]]
+            (let [sym# (f#)]
+              (cond-> ret# sym# (conj sym#))))
+          []
+          (->> (zipmap '~syms
+                 [~@(map
+                      (fn [sym]
+                        `(fn [] (stest/instrument-1 '~sym ~opts-sym)))
+                      syms)])
+            (filter #((stest/instrumentable-syms ~opts-sym) (first %)))
+            (stest/distinct-by first)))))))
+
+(defonce ^:private instrumented-vars (atom {}))
+
+(defn- no-fspec
+  [v spec]
+  (ex-info (str "Fn at " v " is not spec'ed.")
+           {:var v :spec spec ::s/failure :no-fspec}))
+
+(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 v opts]
+  (let [spec (s/get-spec s)
+        {:keys [raw wrapped]} (get @instrumented-vars v)
+        current @v
+        to-wrap (if (= wrapped current) raw current)
+        ospec (c/or (instrument-choose-spec spec s opts)
+                    (throw (no-fspec v spec)))
+        ofn (instrument-choose-fn to-wrap ospec s opts)
+        checked (@#'stest/spec-checking-fn v ofn ospec)]
+    (swap! instrumented-vars assoc v {:raw to-wrap :wrapped checked})
+    checked))
+
+(macros/defmacro instrument-1
+  [[_quote s] opts]
+  (let [&env (ctx/get-ctx)]
+    (when-let [v (sci/resolve &env s)]
+      (let [v (meta v)
+            var-name (:name v)]
+        (when (and (nil? (:const v))
+                   (nil? (:macro v))
+                   (contains? (speced-vars)
+                              var-name))
+          `(let [the-var# (resolve '~s)
+                 checked# (#'stest/instrument-1* '~s the-var# ~opts)]
+             (when checked# (set! ~s checked#))
+             '~var-name))))))
+
 (def namespaces {'cljs.spec.alpha {'def (sci/copy-var def* sns)
                                    'def-impl (sci/copy-var s/def-impl sns)
                                    'and (sci/copy-var and sns)
@@ -539,14 +689,20 @@
                                    'int-in (sci/copy-var int-in sns)
                                    'MAX_INT s/MAX_INT
                                    'int-in-range? (sci/copy-var s/int-in-range? sns)
-                                   'nonconforming (sci/copy-var s/nonconforming sns)}
+                                   'nonconforming (sci/copy-var s/nonconforming sns)
+                                   'speced-vars (sci/copy-var speced-vars sns)}
                  'cljs.spec.gen.alpha {'fmap (sci/copy-var gen/fmap gns)
                                        'elements (sci/copy-var gen/elements gns)
                                        'large-integer* (sci/copy-var gen/large-integer* gns)
                                        'shuffle (sci/copy-var gen/shuffle gns)
                                        'generate (sci/copy-var gen/generate gns)
                                        'map (sci/copy-var gen/map gns)
-                                       'simple-type (sci/copy-var gen/simple-type gns)}})
+                                       'simple-type (sci/copy-var gen/simple-type gns)}
+                 'cljs.spec.test.alpha {'instrument (sci/copy-var instrument tns)
+                                        'distinct-by (sci/copy-var stest/distinct-by tns)
+                                        'instrumentable-syms (sci/copy-var stest/instrumentable-syms tns)
+                                        'instrument-1 (sci/copy-var instrument-1 tns)
+                                        'instrument-1* (sci/copy-var instrument-1* tns)}})
 
 (def config {:namespaces namespaces})