Skip to content

Commit

Permalink
Fix more bugs in effective-dispatch-value (#56)
Browse files Browse the repository at this point in the history
  • Loading branch information
@camsaul
camsaul authored Jun 5, 2021
1 parent 4b073ab commit d0a8071
Show file tree
Hide file tree
Showing 6 changed files with 187 additions and 41 deletions.
2 changes: 1 addition & 1 deletion project.clj
View file
Original file line number Diff line number Diff line change
@@ -1,4 +1,4 @@
(defproject methodical "0.11.1"
(defproject methodical "0.11.2"
:url "https://github.com/camsaul/methodical"
:min-lein-version "2.5.0"

Expand Down
60 changes: 49 additions & 11 deletions src/methodical/impl/multifn/standard.clj
View file
Original file line number Diff line number Diff line change
Expand Up @@ -6,18 +6,56 @@
[pretty.core :refer [PrettyPrintable]])
(:import [methodical.interface Dispatcher MethodCombination MethodTable MultiFnImpl]))

(defn- effective-dispatch-value
;; "composite dispatch value" below just means a dispatch value consisting of multiple parts e.g. `[:x :y]` as opposed
;; to a single value like `:x`.

(defn sort-dispatch-values
"Sort dispatch values in order from most-specific-overall to least-specific-overall."
[dispatcher dispatch-values]
(sort-by
identity
(dispatcher.common/domination-comparitor (partial i/dominates? dispatcher))
dispatch-values))

(defn composite-effective-dispatch-value
"Combine multiple composite dispatch values into a single composite dispatch value that has the overall most-specific
arg for each position, e.g.
;; String is more specific than Object; ::parrot is more specific than ::bird
(composite-effective-dispatch-value [[Object ::parrot] [String ::bird]]) ; -> [String ::parrot]
If the most-specific dispatch value is not composite, it returns it directly."
[dispatcher dispatch-values]
;; sort the values so in cases where there's ambiguity we take the keep the value in the overall-most-specific
;; dispatch value.
(let [[most-specific-dispatch-value & more-dispatch-values] (sort-dispatch-values dispatcher dispatch-values)]
;; if the most-specific dispatch value is not composite, we can return it as-is -- there's no need to build a
;; composite dispatch value.
(if-not (sequential? most-specific-dispatch-value)
most-specific-dispatch-value
;; otherwise we need to combine stuff
(reduce
(fn [dv1 dv2]
(map
(fn [x y]
(if (i/dominates? dispatcher y x)
y
x))
dv1
dv2))
most-specific-dispatch-value
(filter sequential? more-dispatch-values)))))

(defn effective-dispatch-value
"Given matching `primary-methods` and `aux-methods` for `dispatch-value`, determine the effective dispatch value."
{:arglists '([dispatcher primary-methods aux-methods])}
[dispatcher [most-specific-primary-method] aux-methods]
(let [most-specific-aux-methods (map first (vals aux-methods))
dispatch-values (->> (cons most-specific-primary-method most-specific-aux-methods)
(map meta)
(map :dispatch-value)
(filter some?))]
(first
(sort-by
identity
(dispatcher.common/domination-comparitor (partial i/dominates? dispatcher))
dispatch-values))))
(let [dispatch-values (transduce
(comp cat (map meta) (map :dispatch-value) (filter some?))
conj
[]
(cons [most-specific-primary-method] (vals aux-methods)))]
(composite-effective-dispatch-value dispatcher dispatch-values)))

(defn standard-effective-method
"Build an effective method using the 'standard' technique, taking the dispatch-value-method pairs in the
Expand Down
31 changes: 26 additions & 5 deletions test/methodical/impl/dispatcher/common_test.clj
View file
Original file line number Diff line number Diff line change
Expand Up @@ -59,18 +59,21 @@
(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)}]
5 (partial dispatcher.common/dominates? h prefs ::default)}]
(t/testing (format "%d-arity" arity)
(t/testing "The same"
(t/is (not (dominates? :a :b)))
(t/is (not (dominates? ::bird ::bird))))
(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))))
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))))
Expand All @@ -82,6 +85,24 @@
(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))))))))
(t/is (not (dominates? ::budgie ::love-bird))))
(t/testing "composite dispatch value"
(t/testing "The same"
(t/is (not (dominates? [Object ::parrot] [Object ::parrot]))))
(t/testing "first value more specific"
(t/is (dominates? [String ::parrot] [Object ::parrot]))
(t/is (not (dominates? [Object ::parrot] [String ::parrot]))))
(t/testing "second value more specific"
(t/is (dominates? [Object ::parrot] [Object ::bird]))
(t/is (not (dominates? [Object ::bird] [Object ::parrot])))
(t/is (not (dominates? [Object ::parrot] [Object ::parrot]))))
(t/testing "Mixed-specificity -- neither dispatch value should dominate."
(t/is (not (dominates? [String ::bird] [Object ::parrot])))
(t/is (not (dominates? [Object ::parrot] [String ::bird]))))
(t/testing "Default dispatch value"
(case (long arity)
4 (t/is (not (dominates? [String ::bird] ::default)))
5 (t/is (dominates? [String ::bird] ::default)))
(t/is (not (dominates? ::default [Object ::parrot])))))))))

;; TODO - add tests for `domination-comparitor`, and `ambiguous?`?
28 changes: 13 additions & 15 deletions test/methodical/impl/multifn/cached_test.clj
View file
Original file line number Diff line number Diff line change
Expand Up @@ -33,19 +33,17 @@

(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})]
(doseq [dv1-permutation (combo/permutations [nil Object Number])
dv2-permutation (combo/permutations [::bird ::parrot ::dog])]
(let [f (-> (m/default-multifn (fn [x y] [x (:type y)]))
(m/add-primary-method :default (fn [_ _ m] m))
(m/add-aux-method :before [:default ::bird] (fn [_ m] (assoc m :bird? true)))
(m/add-aux-method :before [Object :default] (fn [_ m] (assoc m :object? true))))]
(t/testing (format "\norder = %s %s" (pr-str dv1-permutation) (pr-str dv2-permutation))
(doseq [[dv1 dv2 :as dv] (map vector dv1-permutation dv2-permutation)]
(t/testing (format "\n dispatch value = %s" (pr-str dv))
(let [expected (cond-> {:type dv2}
(isa? dv1 Object) (assoc :object? true)
(isa? dv2 ::bird) (assoc :bird? true))]
(t/is (= expected
(f {:type v}))))))))))))
(f dv1 {:type dv2}))))))))))))
74 changes: 69 additions & 5 deletions test/methodical/impl/multifn/standard_test.clj
View file
Original file line number Diff line number Diff line change
@@ -1,14 +1,53 @@
(ns methodical.impl.multifn.standard-test
(:require [clojure.test :as t]
(:require [clojure.math.combinatorics :as combo]
[clojure.test :as t]
[methodical.core :as m]
[methodical.impl.multifn.standard :as standard]))

(derive ::parrot ::bird)
(derive ::parakeet ::parrot)
(derive ::budgie ::parakeet)
(derive ::love-bird ::parrot)

(t/deftest sort-dispatch-values-test
(let [dispatcher (m/multi-default-dispatcher (fn [x y] [x y]) :default-value ::default)]
;; in cases where there's ambiguity (e.g. `[Integer ::parrot]` and `[Double ::parrot]`, keep the first value
(doseq [permutation (combo/permutations [[Integer ::parrot] [Number ::parrot] [Object ::bird] ::default])
:let [permutation (cons [Double ::parrot] permutation)]]
(t/testing (vec permutation)
(t/is (= [[Double ::parrot] [Integer ::parrot] [Number ::parrot] [Object ::bird] ::default]
(standard/sort-dispatch-values dispatcher permutation)))))))

(t/deftest composite-effective-dispatch-value-test
(doseq [[dispatch-values expected]
{[[Object ::parrot]]
[Object ::parrot]

[[Object ::parrot] [String ::bird]]
[String ::parrot]

[[Object ::parrot] [String ::default]]
[String ::parrot]

[[Object ::parrot] [String ::default] ::default]
[String ::parrot]

[::default ::default]
::default}
dispatch-values (distinct (combo/permutations dispatch-values))]
(t/testing dispatch-values
(t/is (= expected
(standard/composite-effective-dispatch-value
(m/multi-default-dispatcher (fn [x y] [x y]) :default-value ::default)
dispatch-values)))))
(t/testing "If there's ambiguity between values, always prefer values from the first dispatch value"
(t/is (= [String ::parakeet]
(standard/composite-effective-dispatch-value
(m/multi-default-dispatcher (fn [x y] [x y]) :default-value ::default)
[[String ::parrot] [Number ::parrot] [Object ::parakeet]])))))

(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)
Expand All @@ -24,4 +63,29 @@
::love-bird ::parrot}]
(t/testing dv
(t/is (= {:dispatch-value expected}
(meta (standard/standard-effective-method combo dispatcher method-table dv))))))))

(t/testing "multiple dispatch values"
(let [combo (m/thread-last-method-combination)
dispatcher (m/multi-default-dispatcher vector)
method-table (-> (m/standard-method-table)
(m/add-primary-method :default (fn [_]))
(m/add-aux-method :after [:default ::bird] (fn [_]))
(m/add-aux-method :after [:default ::parrot] (fn [_]))
(m/add-aux-method :before [Object :default] (fn [_]))
(m/add-aux-method :before [Number :default] (fn [_])))]
(doseq [[dv1 expected-1] {nil :default
Object Object
String Object
Number Number
Integer Number}
[dv2 expected-2] {::dog :default
::bird ::bird
::parrot ::parrot
::parakeet ::parrot}
:let [dv [dv1 dv2]]]
(t/testing dv
(t/is (= {:dispatch-value (if (= [expected-1 expected-2] [:default :default])
:default
[expected-1 expected-2])}
(meta (standard/standard-effective-method combo dispatcher method-table dv)))))))))
33 changes: 29 additions & 4 deletions test/methodical/util_test.clj
View file
Original file line number Diff line number Diff line change
Expand Up @@ -130,13 +130,38 @@
(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
(doseq [[dv expected] {::dog :default
::bird ::bird
::parrot ::parrot
::parakeet ::parrot}]
(t/testing dv
(t/is (= expected
(m/effective-dispatch-value f dv))))))))
(m/effective-dispatch-value f dv)))))))
(t/testing "composite dispatch value"
(let [f (-> (m/default-multifn (fn [x y] [x (:type y)]))
(m/add-primary-method :default (fn [_ _ m] m))
(m/add-aux-method :before [:default ::bird] (fn [_ m] (assoc m :bird? true)))
(m/add-aux-method :before [Object :default] (fn [_ m] (assoc m :object? true))))]
(t/is (= [Object :default]
(m/effective-dispatch-value f [Object ::shoe])
(m/effective-dispatch-value f [Object :default])))
(t/is (= [Object ::bird]
(m/effective-dispatch-value f [Object ::parrot])
(m/effective-dispatch-value f [String ::parrot])
(m/effective-dispatch-value f [Object ::parakeet])
(m/effective-dispatch-value f [String ::parakeet])))
(t/is (= [:default ::bird]
(m/effective-dispatch-value f [nil ::parrot])
(m/effective-dispatch-value f [:default ::parrot])
(m/effective-dispatch-value f [nil ::parakeet])
(m/effective-dispatch-value f [:default ::parakeet])))
(t/is (= :default
(m/effective-dispatch-value f :default)
(m/effective-dispatch-value f [nil :default])
(m/effective-dispatch-value f [:default nil])
(m/effective-dispatch-value f [:default :default])
(m/effective-dispatch-value f [:default ::shoe])
(m/effective-dispatch-value f [nil ::shoe]))))))

(t/deftest dispatch-fn-test
(t/testing "dispatch-fn"
Expand Down

0 comments on commit d0a8071

Please sign in to comment.