Use orchard.query for apropos and tests

project.clj

@@ -30,7 +30,7 @@
 
   :test-selectors {:default (fn [test-meta]
                               (if-let [min-version (:min-clj-version test-meta)]
-                                (>= (compare (clojure-version) min-version) 0 )
+                                (>= (compare (clojure-version) min-version) 0)
                                 true))}
 
   :aliases {"bump-version" ["change" "version" "leiningen.release/bump-version"]}

src/cider/nrepl.clj

@@ -436,11 +436,14 @@
   {:doc "Middleware that handles testing requests."
    :requires #{#'session #'wrap-pprint-fn}
    :expects #{#'pr-values}
-   :handles {"test"
-             {:doc "Run tests in the specified namespace and return results. This accepts a set of `tests` to be run; if nil, runs all tests. Results are cached for exception retrieval and to enable re-running of failed/erring tests."
+   :handles {"test-var-query"
+             {:doc "Run tests specified by the `var-query` and return results. Results are cached for exception retrieval and to enable re-running of failed/erring tests."
+              :optional wrap-pprint-fn-optional-arguments}
+             "test"
+             {:doc "[DEPRECATED] Run tests in the specified namespace and return results. This accepts a set of `tests` to be run; if nil, runs all tests. Results are cached for exception retrieval and to enable re-running of failed/erring tests."
               :optional wrap-pprint-fn-optional-arguments}
              "test-all"
-             {:doc "Run all tests in the project. If `load?` is truthy, all project namespaces are loaded; otherwise, only tests in presently loaded namespaces are run. Results are cached for exception retrieval and to enable re-running of failed/erring tests."
+             {:doc "[DEPRECATED] Run all tests in the project. If `load?` is truthy, all project namespaces are loaded; otherwise, only tests in presently loaded namespaces are run. Results are cached for exception retrieval and to enable re-running of failed/erring tests."
               :optional wrap-pprint-fn-optional-arguments}
              "test-stacktrace"
              {:doc "Rerun all tests that did not pass when last run. Results are cached for exception retrieval and to enable re-running of failed/erring tests."

src/cider/nrepl/middleware/apropos.clj

@@ -2,12 +2,36 @@
   "Search symbols and docs matching a regular expression"
   {:author "Jeff Valk"}
   (:require [cider.nrepl.middleware.util.error-handling :refer [with-safe-transport]]
-            [orchard.apropos :as apropos]))
+            [orchard.apropos :as apropos]
+            [cider.nrepl.middleware.util.coerce :as util.coerce]))
 
 ;;; ## Middleware
 
 (defn apropos [msg]
-  {:apropos-matches (apropos/find-symbols msg)})
+  {:apropos-matches
+   (apropos/find-symbols
+    (cond-> msg
+      ;; Compatibility for the pre-var-query API
+      (:privates? msg)
+      (assoc-in [:var-query :private?] true)
+
+      (:query msg)
+      (assoc-in [:var-query :search] (:query msg))
+
+      (not (:case-sensitive? msg))
+      (update-in [:var-query :search] #(format "(?i:%s)" %))
+
+      (:docs? msg)
+      (assoc-in [:var-query :search-property] :doc)
+
+      (:docs? msg)
+      (assoc :full-doc? true)
+
+      true
+      (update :var-query util.coerce/var-query)
+
+      (:ns msg)
+      (update :ns (comp find-ns symbol))))})
 
 (defn handle-apropos [handler msg]
   (with-safe-transport handler msg

src/cider/nrepl/middleware/test.clj

@@ -4,8 +4,10 @@
   (:require [cider.nrepl.middleware.pprint :as pprint]
             [cider.nrepl.middleware.stacktrace :as st]
             [cider.nrepl.middleware.test.extensions :as extensions]
+            [cider.nrepl.middleware.util.coerce :as util.coerce]
             [orchard.misc :as u]
             [orchard.namespace :as ns]
+            [orchard.query :as query]
             [clojure.pprint :as pp]
             [clojure.test :as test]
             [clojure.tools.nrepl.middleware.interruptible-eval :as ie]
@@ -197,85 +199,55 @@
                               :message "Uncaught exception, not in assertion"})))
       (test/do-report {:type :end-test-var :var v}))))
 
-(defn- var-filter
-  [var include exclude]
-  (let [test-inclusion (if include
-                         #((apply some-fn include) (meta %))
-                         (constantly true))
-        test-exclusion (if exclude
-                         #((complement (apply some-fn exclude)) (meta %))
-                         (constantly true))]
-    (and (test-inclusion var)
-         (test-exclusion var))))
-
 (defn test-vars
   "Call `test-var` on each var, with the fixtures defined for namespace object
-  `ns`.  If `include` is a seq, only vars with the metadata marker contained
-  within are tested.  If `exclude` is a seq, vars with the metadata marker
-  contained within are not tested.  If both inclusions and exclusions are
-  present, exclusions take priority over inclusions."
-
-  [ns include exclude vars]
+  `ns`."
+  [ns vars]
   (let [once-fixture-fn (test/join-fixtures (::test/once-fixtures (meta ns)))
-        each-fixture-fn (test/join-fixtures (::test/each-fixtures (meta ns)))
-        include (seq (map keyword include))
-        exclude (seq (map keyword exclude))]
+        each-fixture-fn (test/join-fixtures (::test/each-fixtures (meta ns)))]
     (try (once-fixture-fn
           (fn []
             (doseq [v vars]
-              (when (and (:test (meta v))
-                         (var-filter v include exclude))
-                (each-fixture-fn (fn [] (test-var v)))))))
+              (each-fixture-fn (fn [] (test-var v))))))
          (catch Throwable e
            (report-fixture-error ns e)))))
 
 (defn test-ns
   "If the namespace object defines a function named `test-ns-hook`, call that.
-  Otherwise, test the specified vars. If no vars are specified, test all vars
-  in the namespace. On completion, return a map of test results.
-
-  If `include` is a seq, only vars with the metadata marker contained within
-  are tested.  If `exclude` is a seq, vars with the metadata marker contained
-  within are not tested.  If both inclusions and exclusions are present,
-  exclusions take priority over inclusions."
-  [ns include exclude vars]
+  Otherwise, test the specified vars. On completion, return a map of test
+  results."
+  [ns vars]
   (binding [test/report report]
     (test/do-report {:type :begin-test-ns, :ns ns})
     (if-let [test-hook (ns-resolve ns 'test-ns-hook)]
       (test-hook)
-      (test-vars ns include exclude (or (seq vars)
-                                        (vals (ns-interns ns)))))
+      (test-vars ns vars))
     (test/do-report {:type :end-test-ns, :ns ns})
     @current-report))
 
+(defn test-var-query
+  "Call `test-ns` for each var found via var-query."
+  [var-query]
+  (report-reset!)
+  (doseq [[ns vars] (group-by
+                     (comp :ns meta)
+                     (query/vars var-query))]
+    (test-ns ns vars))
+  @current-report)
+
 (defn test-nss
   "Call `test-ns` for each entry in map `m`, in which keys are namespace
   symbols and values are var symbols to be tested in that namespace (or `nil`
-  to test all vars). Symbols are first resolved to their corresponding objects.
-  If `include` is a seq, only vars with the metadata marker contained within
-  are tested.  If `exclude` is a seq, vars with the metadata marker contained
-  within are not tested.  If both inclusions and exclusions are present,
-  exclusions take priority over inclusions."
-  [m include exclude]
+  to test all vars). Symbols are first resolved to their corresponding
+  objects."
+  [m]
   (report-reset!)
   (doseq [[ns vars] m]
     (->> (map (partial ns-resolve ns) vars)
          (filter identity)
-         (test-ns (the-ns ns) include exclude)))
+         (test-ns (the-ns ns))))
   @current-report)
 
-;;; ## Metadata Utils
-
-(defn has-tests?
-  "Return a truthy value if the namespace has any `:test` metadata."
-  [ns]
-  (when-let [ns-obj
-             (if (instance? clojure.lang.Namespace ns)
-               ns
-               (find-ns ns))]
-    (seq (filter (comp :test meta val)
-                 (ns-interns ns-obj)))))
-
 ;;; ## Middleware
 
 (def results
@@ -300,29 +272,41 @@
                              ~@body)
                            (alter-meta! session# dissoc :thread :eval-msg))))))
 
-(defn handle-test-op
-  [{:keys [ns tests session transport include exclude] :as msg}]
-  (with-interruptible-eval msg
-    (if-let [ns (ns/ensure-namespace ns)]
-      (let [nss {ns (map u/as-sym tests)}
-            report (test-nss nss include exclude)]
+(defn handle-test-var-query-op
+  [{:keys [var-query transport] :as msg}]
+  (with-interruptible-eval
+    msg
+    (try
+      (let [report (test-var-query
+                    (-> var-query
+                        (assoc-in [:ns-query :has-tests?] true)
+                        (assoc :test? true)
+                        (util.coerce/var-query)))]
         (reset! results (:results report))
         (t/send transport (response-for msg (u/transform-value report))))
-      (t/send transport (response-for msg :status :namespace-not-found)))
+      (catch clojure.lang.ExceptionInfo e
+        (let [d (ex-data e)]
+          (if (::util.coerce/id d)
+            (case (::util.coerce/id d)
+              :namespace-not-found (t/send transport (response-for msg :status :namespace-not-found)))
+            (throw e)))))
     (t/send transport (response-for msg :status :done))))
 
+(defn handle-test-op
+  [{:keys [ns tests include exclude] :as msg}]
+  (handle-test-var-query-op
+   (merge msg {:var-query {:ns-query {:exactly [ns]}
+                           :include-meta-key include
+                           :exclude-meta-key exclude
+                           :exactly tests}})))
+
 (defn handle-test-all-op
-  [{:keys [load? session transport include exclude] :as msg}]
-  (with-interruptible-eval msg
-    (let [nss (zipmap (->> (if load?
-                             (ns/load-project-namespaces)
-                             (ns/loaded-project-namespaces))
-                           (filter has-tests?))
-                      (repeat nil))
-          report (test-nss nss include exclude)]
-      (reset! results (:results report))
-      (t/send transport (response-for msg (u/transform-value report))))
-    (t/send transport (response-for msg :status :done))))
+  [{:keys [load? include exclude] :as msg}]
+  (handle-test-var-query-op
+   (merge msg {:var-query {:ns-query {:project? true
+                                      :load-project-ns? load?}
+                           :include-meta-key include
+                           :exclude-meta-key exclude}})))
 
 (defn handle-retest-op
   [{:keys [session transport] :as msg}]
@@ -333,7 +317,7 @@
                               vars (distinct (map :var problems))]
                           (if (seq vars) (assoc ret ns vars) ret)))
                       {} @results)
-          report (test-nss nss nil nil)]
+          report (test-nss nss)]
       (reset! results (:results report))
       (t/send transport (response-for msg (u/transform-value report))))
     (t/send transport (response-for msg :status :done))))
@@ -357,6 +341,7 @@
 (defn handle-test [handler msg & configuration]
   (let [executor (:executor configuration @default-executor)]
     (case (:op msg)
+      "test-var-query"  (handle-test-var-query-op (assoc msg :executor executor))
       "test"            (handle-test-op (assoc msg :executor executor))
       "test-all"        (handle-test-all-op (assoc msg :executor executor))
       "test-stacktrace" (handle-stacktrace-op (assoc msg :executor executor))

src/cider/nrepl/middleware/util/coerce.clj

@@ -0,0 +1,40 @@
+(ns cider.nrepl.middleware.util.coerce
+  "Coercion utilities for coercing bencoded maps.")
+
+(defn- update-some
+  [m k & args]
+  (if (get m k)
+    (apply update m k args)
+    m))
+
+(defn ns-query
+  "Poke and prod at a bencoded ns-query until it is in the form that orchard
+  expects."
+  [ns-query]
+  (-> ns-query
+      (update-some :exactly
+                   #(map (fn [ns-string]
+                           (if-let [ns (find-ns (symbol ns-string))]
+                             ns
+                             (throw (ex-info "Namespace not found"
+                                             {::id :namespace-not-found
+                                              :namespace-string ns-string}))))
+                         %))
+      (update :project? some?)
+      (update :load-project-ns? some?)
+      (update :has-tests? some?)
+      (update-some :include-regexps #(map re-pattern %))
+      (update-some :exclude-regexps #(map re-pattern %))))
+
+(defn var-query
+  [var-query]
+  (-> var-query
+      (update :ns-query ns-query)
+      (update-some :exactly #(map (comp find-ns symbol) %))
+      (update :test? some?)
+      (update :private? some?)
+      (update-some :include-meta-key #(map keyword %))
+      (update-some :exclude-meta-key #(map keyword %))
+      (update-some :search re-pattern)
+      (update-some :search-property keyword)
+      (dissoc :manipulate-vars)))

test/clj/cider/nrepl/middleware/test_test.clj

@@ -1,5 +1,7 @@
 (ns cider.nrepl.middleware.test-test
   (:require [cider.nrepl.middleware.test :as test]
+            ;; Ensure tested tests are loaded:
+            cider.nrepl.middleware.test-filter-tests
             [cider.nrepl.test-session :as session]
             [clojure.test :refer :all]))
 
@@ -13,12 +15,7 @@
   (is (= (class @test/default-executor)
          java.util.concurrent.ThreadPoolExecutor)))
 
-(deftest has-tests-errors
-  (is (test/has-tests? 'cider.nrepl.middleware.test-test))
-  ;; clojure-emacs/cider#1940
-  (is (not (test/has-tests? 'this.namespace.does.not.have.tests.or.error))))
-
-(deftest only-smoke-test-run-test
+(deftest only-smoke-test-run-test-deprecated
   (testing "only test marked as smoke is run when test-all is used"
     (let [{:keys [results] :as test-result} (session/message {:op            "test-all"
                                                               :include       ["smoke"]
@@ -51,3 +48,37 @@
       (is ((set (keys results)) :cider.nrepl.middleware.test-filter-tests) "ns that contains smoke is present")
       (is (< 1 (count tests)) "more tests were run")
       (is ((set tests) :a-puff-of-smoke-test) "smoke test is still present without a filter"))))
+
+(deftest only-smoke-test-run-test
+  (testing "only test marked as smoke is run when test-var-query is used"
+    (let [{:keys [results] :as test-result} (session/message {:op "test-var-query"
+                                                              :var-query {:include-meta-key ["smoke"]
+                                                                          :exclude-meta-key ["integration"]}})
+          tests (keys (:cider.nrepl.middleware.test-filter-tests results))]
+      (is ((set (keys results)) :cider.nrepl.middleware.test-filter-tests) "ns that contains smoke is present")
+      (is (= 1 (count tests)) "only one test was run")
+      (is (= :a-puff-of-smoke-test (first tests)) "only the test marked 'smoke' was run")))
+  (testing "only test marked as smoke is run when test-ns is used"
+    (let [{:keys [results] :as test-result} (session/message {:op "test-var-query"
+                                                              :var-query {:ns-query {:exactly ["cider.nrepl.middleware.test-filter-tests"]}
+                                                                          :include-meta-key ["smoke"]
+                                                                          :exclude-meta-key ["integration"]}})
+          tests (keys (:cider.nrepl.middleware.test-filter-tests results))]
+      (is ((set (keys results)) :cider.nrepl.middleware.test-filter-tests) "ns that contains smoke is present")
+      (is (= 1 (count tests)) "only one test was run")
+      (is (= :a-puff-of-smoke-test (first tests)) "only the test marked 'smoke' was run")))
+  (testing "only test not marked as integration is run when test-ns is used"
+    (let [{:keys [results] :as test-result} (session/message {:op "test-var-query"
+                                                              :var-query {:ns-query {:exactly ["cider.nrepl.middleware.test-filter-tests"]}
+                                                                          :exclude-meta-key ["integration"]}})
+          tests (keys (:cider.nrepl.middleware.test-filter-tests results))]
+      (is ((set (keys results)) :cider.nrepl.middleware.test-filter-tests) "ns that contains smoke is present")
+      (is (= 2 (count tests)) "only one test was run")
+      (is (= #{:a-puff-of-smoke-test :yet-an-other-test} (set tests)) "only the test marked 'smoke' was run")))
+  (testing "marked test is still run if filter is not used"
+    (let [{:keys [results] :as test-result} (session/message {:op "test-var-query"
+                                                              :var-query {:ns-query {:exactly ["cider.nrepl.middleware.test-filter-tests"]}}})
+          tests (keys (:cider.nrepl.middleware.test-filter-tests results))]
+      (is ((set (keys results)) :cider.nrepl.middleware.test-filter-tests) "ns that contains smoke is present")
+      (is (< 1 (count tests)) "more tests were run")
+      (is ((set tests) :a-puff-of-smoke-test) "smoke test is still present without a filter"))))