Fix bug with new dominates? method and related 11.0 features (#55)

* Fix bug in new dominates? and related new 0.11.0 features

* Bump version -> 0.11.1

* Lint fix.

project.clj

@@ -1,4 +1,4 @@
-(defproject methodical "0.11.0"
+(defproject methodical "0.11.1"
   :url "https://github.com/camsaul/methodical"
   :min-lein-version "2.5.0"
 
@@ -32,6 +32,7 @@
   {:dev
    {:dependencies
     [[org.clojure/clojure "1.10.3"]
+     [org.clojure/math.combinatorics "0.1.6"]
      [criterium "0.4.6"]
      [pjstadig/humane-test-output "0.11.0"]]
 

src/methodical/impl/dispatcher/common.clj

@@ -36,25 +36,43 @@
 (defn dominates?
   "True if dispatch value `x` should be considered more specific for purposes of method combination over dispatch value
   `y`, e.g. because `x` derives from `y`, or because `x` (or one of its ancestors) has been explicitly preferred over
-  `y` (or one of its ancestors)."
-  [hierarchy prefs x y]
-  (and
-   (not= x y)
-   (or (prefers? hierarchy prefs x y)
-       (isa? hierarchy x y))))
+  `y` (or one of its ancestors).
+
+  4-arity version does not take the `default-dispatch-value` into account, but 5-arity version does."
+  ([hierarchy prefs x y]
+   (assert (:parents hierarchy) (format "Not a valid hierarchy: %s" (pr-str hierarchy)))
+   (and
+    (not= x y)
+    (or (prefers? hierarchy prefs x y)
+        (isa? hierarchy x y))))
+
+  ([hierarchy prefs default-dispatch-value x y]
+   (or (dominates? hierarchy prefs x y)
+       (and (not= x y)
+            (not= x default-dispatch-value)
+            (= y default-dispatch-value)))))
 
 (defn domination-comparitor
-  "Given a `hierarchy prefs` return a function that can be used to sort dispatch values from most-specific to
+  "Given a `hierarchy` and `prefs` return a function that can be used to sort dispatch values from most-specific to
   least-specific."
-  [hierarchy prefs dispatch-value]
-  (fn [x y]
-    (cond
-      (= x y)                           0
-      (= x dispatch-value)             -2
-      (= y dispatch-value)              2
-      (dominates? hierarchy prefs x y) -1
-      (dominates? hierarchy prefs y x)  1
-      :else                             0)))
+  ([dominates?-pred]
+   (fn [x y]
+     (cond
+       (= x y)               0
+       (dominates?-pred x y) -1
+       (dominates?-pred y x) 1
+       :else                 0)))
+
+  ([hierarchy prefs]
+   (domination-comparitor (partial dominates? hierarchy prefs)))
+
+  ([hierarchy prefs dispatch-value]
+   (let [f (domination-comparitor hierarchy prefs)]
+     (fn [x y]
+       (condp = dispatch-value
+         x -2
+         y 2
+         (f x y))))))
 
 (defn ambiguous?
   "True if neither `dispatch-val-x` nor `dispatch-val-y` dominate one another, e.g. because they are the same value or

src/methodical/impl/dispatcher/everything.clj

@@ -35,13 +35,13 @@
 
   (matching-primary-methods [_ method-table _]
     (let [primary-methods (i/primary-methods method-table)
-          comparitor      (dispatcher.common/domination-comparitor (var-get hierarchy-var) prefs ::no-dispatch-value)]
+          comparitor      (dispatcher.common/domination-comparitor (var-get hierarchy-var) prefs)]
       (for [[dispatch-value method] (sort-by first comparitor primary-methods)]
         (vary-meta method assoc :dispatch-value dispatch-value))))
 
   (matching-aux-methods [_ method-table _]
     (let [aux-methods (i/aux-methods method-table)
-          comparitor  (dispatcher.common/domination-comparitor (var-get hierarchy-var) prefs ::no-dispatch-value)]
+          comparitor  (dispatcher.common/domination-comparitor (var-get hierarchy-var) prefs)]
       (into {} (for [[qualifier dispatch-value->methods] aux-methods]
                  [qualifier (for [[dispatch-value methods] (sort-by first comparitor dispatch-value->methods)
                                   method methods]

src/methodical/impl/dispatcher/multi_default.clj

@@ -186,4 +186,4 @@
         (MultiDefaultDispatcher. dispatch-fn hierarchy-var default-value new-prefs))))
 
   (dominates? [_ x y]
-    (dispatcher.common/dominates? (var-get hierarchy-var) prefs x y)))
+    (dispatcher.common/dominates? (var-get hierarchy-var) prefs default-value x y)))

src/methodical/impl/dispatcher/standard.clj

@@ -154,4 +154,4 @@
         (StandardDispatcher. dispatch-fn hierarchy-var default-value new-prefs))))
 
   (dominates? [_ x y]
-    (dispatcher.common/dominates? (var-get hierarchy-var) prefs x y)))
+    (dispatcher.common/dominates? (var-get hierarchy-var) prefs default-value x y)))

src/methodical/impl/multifn/standard.clj

@@ -1,6 +1,7 @@
 (ns methodical.impl.multifn.standard
   "Standard Methodical MultiFn impl, which "
-  (:require [methodical.interface :as i]
+  (:require [methodical.impl.dispatcher.common :as dispatcher.common]
+            [methodical.interface :as i]
             [potemkin.types :as p.types]
             [pretty.core :refer [PrettyPrintable]])
   (:import [methodical.interface Dispatcher MethodCombination MethodTable MultiFnImpl]))
@@ -15,7 +16,7 @@
     (first
      (sort-by
       identity
-      (comparator (partial i/dominates? dispatcher))
+      (dispatcher.common/domination-comparitor (partial i/dominates? dispatcher))
       dispatch-values))))
 
 (defn standard-effective-method

test/methodical/impl/dispatcher/common_test.clj

@@ -51,4 +51,37 @@
            (dispatcher.common/distinct-by first
                                           (list [:a 1] [:a 2] [:b 3] [:c 4] [:c 5] [:b 6] [:a 7] [:d 8] [:d 9])))))
 
-;; TODO - add tests for `dominates?`, `domination-comparitor`, and `ambiguous?`?
+(t/deftest dominates?-test
+  (derive ::parrot ::bird)
+  (derive ::parakeet ::parrot)
+  (derive ::budgie ::parakeet)
+  (derive ::love-bird ::parrot)
+  (let [h     @#'clojure.core/global-hierarchy
+        prefs {:x #{:y}}]
+    (doseq [[arity dominates?] {4 (partial dispatcher.common/dominates? h prefs)
+                                5 (partial dispatcher.common/dominates? h prefs :default)}]
+      (t/testing (format "%d-arity" arity)
+        (t/testing "No relation"
+          (t/is (not (dominates? :a :b))))
+        (t/testing "no relation, but a preference"
+          (t/is (dominates? :x :y))
+          (t/is (not (dominates? :y :x))))
+        (t/testing "default dispatch value"
+          (case (long arity)
+            4 (t/is (not (dominates? ::bird :default)))
+            5 (t/is (dominates? ::bird :default)))
+          (t/is (not (dominates? :default ::bird))))
+        (t/testing "child"
+          (t/is (dominates? ::parrot ::bird))
+          (t/is (not (dominates? ::bird ::parrot))))
+        (t/testing "indirect descendant"
+          (t/is (dominates? ::budgie ::bird))
+          (t/is (not (dominates? ::bird ::budgie))))
+        (t/testing "siblings"
+          (t/is (not (dominates? ::parakeet ::love-bird)))
+          (t/is (not (dominates? ::love-bird ::parakeet))))
+        (t/testing "same common ancestor, but not siblings"
+          (t/is (not (dominates? ::love-bird ::budgie)))
+          (t/is (not (dominates? ::budgie ::love-bird))))))))
+
+;; TODO - add tests for `domination-comparitor`, and `ambiguous?`?

test/methodical/impl/multifn/cached_test.clj

@@ -1,5 +1,6 @@
 (ns methodical.impl.multifn.cached-test
-  (:require [clojure.test :as t]
+  (:require [clojure.math.combinatorics :as combo]
+            [clojure.test :as t]
             [methodical.core :as m]))
 
 (t/deftest empty-copy-test
@@ -16,13 +17,6 @@
         (t/is (= [:string {:type String}]
                  (multifn' {:type String})))))))
 
-(m/defmulti f
-  keyword)
-
-(m/defmethod f :default
-  [k]
-  k)
-
 (t/deftest dont-create-new-functions-for-the-same-effective-dispatch-value
   (t/testing (str "Reuse existing methods rather than creating new ones when dispatch values have the same effective "
                   "dispatch value (#39)")
@@ -35,4 +29,23 @@
       (let [f (-> (m/default-multifn identity)
                   (m/add-primary-method :default identity))]
         (t/is (identical? (m/effective-method f Integer)
-                          (m/effective-method f Number)))))))
+                          (m/effective-method f Number)))))
+
+    (t/testing "\nCaching should work correctly regardless of what order methods are invoked"
+      (derive ::parrot ::bird)
+      (derive ::parakeet ::parrot)
+      (doseq [permutation (combo/permutations [::bird ::parrot ::parakeet ::dog])]
+        (let [f (-> (m/default-multifn :type)
+                    (m/add-primary-method :default (fn [_ m] m))
+                    (m/add-aux-method :after ::bird #(assoc % :bird? true))
+                    (m/add-aux-method :after ::parrot #(assoc % :parrot? true)))]
+          (t/testing (format "\norder = %s" (mapv name permutation))
+            (doseq [v permutation]
+              (t/testing (format "\n dispatch value = %s" (name v))
+                (let [expected (case v
+                                 ::bird     {:type ::bird, :bird? true}
+                                 ::parrot   {:type ::parrot, :bird? true, :parrot? true}
+                                 ::parakeet {:type ::parakeet, :bird? true, :parrot? true}
+                                 ::dog      {:type ::dog})]
+                  (t/is (= expected
+                           (f {:type v}))))))))))))

test/methodical/impl/multifn/standard_test.clj

@@ -0,0 +1,27 @@
+(ns methodical.impl.multifn.standard-test
+  (:require [clojure.test :as t]
+            [methodical.core :as m]
+            [methodical.impl.multifn.standard :as standard]))
+
+(t/deftest standard-effective-method-dispatch-value-test
+  (t/testing "standard-effective-method should return a method with the correct ^:dispatch-value metadata"
+    (derive ::parrot ::bird)
+    (derive ::parakeet ::parrot)
+    (derive ::budgie ::parakeet)
+    (derive ::love-bird ::parrot)
+    (let [combo        (m/thread-last-method-combination)
+          dispatcher   (m/multi-default-dispatcher :type)
+          method-table (-> (m/standard-method-table)
+                           (m/add-primary-method :default (fn [_]))
+                           (m/add-primary-method ::parakeet (fn [_]))
+                           (m/add-aux-method :after ::bird (fn [_]))
+                           (m/add-aux-method :after ::parrot (fn [_])))]
+      (doseq [[dv expected] {::dog       :default
+                             ::bird      ::bird
+                             ::parrot    ::parrot
+                             ::parakeet  ::parakeet
+                             ::budgie    ::parakeet
+                             ::love-bird ::parrot}]
+        (t/testing dv
+          (t/is (= {:dispatch-value expected}
+                   (meta (standard/standard-effective-method combo dispatcher method-table dv)))))))))

test/methodical/util_test.clj

@@ -122,7 +122,21 @@
             (t/testing "aux method(s) are more specific than primary method"
               (t/is (= Number
                        (u/effective-dispatch-value f3 Number)
-                       (u/effective-dispatch-value f3 Integer))))))))))
+                       (u/effective-dispatch-value f3 Integer)))))))))
+  (t/testing "keyword aux methods"
+    (derive ::parrot ::bird)
+    (derive ::parakeet ::parrot)
+    (let [f (-> (m/default-multifn :type)
+                (m/add-primary-method :default (fn [_]))
+                (m/add-aux-method :after ::bird (fn [_]))
+                (m/add-aux-method :after ::parrot (fn [_])))]
+      (doseq [[dv expected] {::dog :default
+                             ::bird ::bird
+                             ::parrot ::parrot
+                             ::parakeet ::parrot}]
+        (t/testing dv
+          (t/is (= expected
+                   (m/effective-dispatch-value f dv))))))))
 
 (t/deftest dispatch-fn-test
   (t/testing "dispatch-fn"