From a6aaaf097b2bdb4953197290b7a893f74666267d Mon Sep 17 00:00:00 2001 From: Cam Saul <1455846+camsaul@users.noreply.github.com> Date: Fri, 19 Aug 2022 15:40:07 -0700 Subject: [PATCH] Breaking change: Replace `Dispatcher` `prefer-method` with `with-prefers` (#105) * Replace Dispatcher/prefer-method with Dispatcher/with-prefers * Test fix --- src/methodical/core.clj | 6 ++- src/methodical/impl/dispatcher/common.clj | 17 -------- src/methodical/impl/dispatcher/everything.clj | 7 +-- .../impl/dispatcher/multi_default.clj | 7 +-- src/methodical/impl/dispatcher/standard.clj | 9 ++-- src/methodical/impl/standard.clj | 4 +- src/methodical/interface.clj | 6 +-- src/methodical/util.clj | 43 ++++++++++++++++++- test/methodical/clojure_test.clj | 32 +++++++------- .../impl/dispatcher/common_test.clj | 24 ----------- test/methodical/util_test.clj | 26 +++++++++++ 11 files changed, 100 insertions(+), 81 deletions(-) diff --git a/src/methodical/core.clj b/src/methodical/core.clj index 109eaa1..6e61db4 100644 --- a/src/methodical/core.clj +++ b/src/methodical/core.clj @@ -36,7 +36,7 @@ ;; Dispatcher default-dispatch-value prefers - prefer-method + with-prefers dominates? ;; MultiFnImpl method-combination @@ -100,6 +100,7 @@ add-aux-method-with-unique-key remove-aux-method-with-unique-key remove-all-methods + prefer-method ;; destructive ops add-primary-method! remove-primary-method! @@ -111,7 +112,8 @@ add-aux-method-with-unique-key! remove-aux-method-with-unique-key! remove-all-methods! - prefer-method!] + prefer-method! + with-prefers!] [methodical.util.trace trace]) diff --git a/src/methodical/impl/dispatcher/common.clj b/src/methodical/impl/dispatcher/common.clj index 2f50785..a766622 100644 --- a/src/methodical/impl/dispatcher/common.clj +++ b/src/methodical/impl/dispatcher/common.clj @@ -1,23 +1,6 @@ (ns methodical.impl.dispatcher.common "Utility functions for implementing Dispatchers.") -(defn add-preference - "Add a method preference to `prefs` for dispatch value `x` over `y`. Used to implement `prefer-method`. `isa?*` is - used to determine whether a relationship between `x` and `y` that precludes this preference already exists; it can - be `clojure.core/isa?`, perhaps partially bound with a hierarchy, or some other 2-arg predicate function." - [isa?* prefs x y] - (when (= x y) - (throw (IllegalStateException. (format "Cannot prefer dispatch value %s over itself." x)))) - (when (contains? (get prefs y) x) - (throw (IllegalStateException. (format "Preference conflict in multimethod: %s is already preferred to %s" y x)))) - ;; this is not actually a restriction that is enforced by vanilla Clojure multimethods, but after thinking about - ;; it really doesn't seem to make sense to allow you to define a preference that will never be used - (when (isa?* y x) - (throw (IllegalStateException. - (format "Preference conflict in multimethod: cannot prefer %s over its descendant %s." - x y)))) - (update prefs x #(conj (set %) y))) - (defn prefers? "True if `x` or one of its ancestors is prefered over `y` or one of its ancestors." [hierarchy prefs x y] diff --git a/src/methodical/impl/dispatcher/everything.clj b/src/methodical/impl/dispatcher/everything.clj index e1b9348..3320a69 100644 --- a/src/methodical/impl/dispatcher/everything.clj +++ b/src/methodical/impl/dispatcher/everything.clj @@ -54,11 +54,8 @@ (prefers [_] prefs) - (prefer-method [this x y] - (let [new-prefs (dispatcher.common/add-preference (partial isa? (deref hierarchy-var)) prefs x y)] - (if (= prefs new-prefs) - this - (EverythingDispatcher. hierarchy-var new-prefs)))) + (with-prefers [_this new-prefs] + (EverythingDispatcher. hierarchy-var new-prefs)) (dominates? [_ x y] (dispatcher.common/dominates? (deref hierarchy-var) prefs x y))) diff --git a/src/methodical/impl/dispatcher/multi_default.clj b/src/methodical/impl/dispatcher/multi_default.clj index 9a98bdf..a513b52 100644 --- a/src/methodical/impl/dispatcher/multi_default.clj +++ b/src/methodical/impl/dispatcher/multi_default.clj @@ -177,11 +177,8 @@ (prefers [_] prefs) - (prefer-method [this x y] - (let [new-prefs (dispatcher.common/add-preference (partial isa? (deref hierarchy-var)) prefs x y)] - (if (= prefs new-prefs) - this - (MultiDefaultDispatcher. dispatch-fn hierarchy-var default-value new-prefs)))) + (with-prefers [_this new-prefs] + (MultiDefaultDispatcher. dispatch-fn hierarchy-var default-value new-prefs)) (dominates? [_ x y] (dispatcher.common/dominates? (deref hierarchy-var) prefs default-value x y))) diff --git a/src/methodical/impl/dispatcher/standard.clj b/src/methodical/impl/dispatcher/standard.clj index 05727a3..9445efe 100644 --- a/src/methodical/impl/dispatcher/standard.clj +++ b/src/methodical/impl/dispatcher/standard.clj @@ -1,7 +1,7 @@ (ns methodical.impl.dispatcher.standard "A single-hierarchy dispatcher that behaves similarly to the way multimethod dispatch is done by vanilla Clojure multimethods, but with added support for auxiliary methods." - (:refer-clojure :exclude [prefers prefer-method methods]) + (:refer-clojure :exclude [prefers methods]) (:require [methodical.impl.dispatcher.common :as dispatcher.common] [methodical.interface :as i] [potemkin.types :as p.types] @@ -147,11 +147,8 @@ (prefers [_] prefs) - (prefer-method [this x y] - (let [new-prefs (dispatcher.common/add-preference (partial isa? (deref hierarchy-var)) prefs x y)] - (if (= prefs new-prefs) - this - (StandardDispatcher. dispatch-fn hierarchy-var default-value new-prefs)))) + (with-prefers [_this new-prefs] + (StandardDispatcher. dispatch-fn hierarchy-var default-value new-prefs)) (dominates? [_ x y] (dispatcher.common/dominates? (deref hierarchy-var) prefs default-value x y))) diff --git a/src/methodical/impl/standard.clj b/src/methodical/impl/standard.clj index 870fb56..c57c064 100644 --- a/src/methodical/impl/standard.clj +++ b/src/methodical/impl/standard.clj @@ -118,8 +118,8 @@ (prefers [_] (i/prefers (.dispatcher impl))) - (prefer-method [this dispatch-val-x dispatch-val-y] - (i/with-dispatcher this (i/prefer-method (.dispatcher impl) dispatch-val-x dispatch-val-y))) + (with-prefers [this new-prefers] + (i/with-dispatcher this (i/with-prefers (.dispatcher impl) new-prefers))) (dominates? [_ dispatch-val-x dispatch-val-y] (i/dominates? (.dispatcher impl) dispatch-val-x dispatch-val-y)) diff --git a/src/methodical/interface.clj b/src/methodical/interface.clj index 88911ca..e8cb261 100644 --- a/src/methodical/interface.clj +++ b/src/methodical/interface.clj @@ -1,5 +1,5 @@ (ns methodical.interface - (:refer-clojure :exclude [isa? prefers prefer-method]) + (:refer-clojure :exclude [isa? prefers]) (:require clojure.core)) ;; this is a dummy dependency until Cloverage 1.3.0 is released -- see @@ -89,8 +89,8 @@ (prefers [dispatcher] "Return a map of preferred dispatch value -> set of other dispatch values.") - (prefer-method [dispatcher dispatch-val-x dispatch-val-y] - "Prefer `dispatch-val-x` over `dispatch-val-y` for dispatch and method combinations.") + (with-prefers [dispatcher new-prefs] + "Return a copy of `dispatcher` with its preferences map replaced with `new-prefs`.") (dominates? [dispatcher dispatch-val-x dispatch-val-y] "Is `dispatch-val-x` considered more specific than `dispatch-val-y`?")) diff --git a/src/methodical/util.clj b/src/methodical/util.clj index 2582fb5..3df13b4 100644 --- a/src/methodical/util.clj +++ b/src/methodical/util.clj @@ -187,6 +187,42 @@ [multifn] (-> multifn remove-all-primary-methods remove-all-aux-methods)) +(defn add-preference + "Add a method preference to `prefs` for dispatch value `x` over `y`. Used to implement `prefer-method`. `isa?*` is + used to determine whether a relationship between `x` and `y` that precludes this preference already exists; it can + be [[clojure.core/isa?]], perhaps partially bound with a hierarchy, or some other 2-arg predicate function." + [isa?* prefs x y] + (when (= x y) + (throw (IllegalStateException. (format "Cannot prefer dispatch value %s over itself." x)))) + (when (contains? (get prefs y) x) + (throw (IllegalStateException. (format "Preference conflict in multimethod: %s is already preferred to %s" y x)))) + ;; this is not actually a restriction that is enforced by vanilla Clojure multimethods, but after thinking about + ;; it really doesn't seem to make sense to allow you to define a preference that will never be used + (when (isa?* y x) + (throw (IllegalStateException. + (format "Preference conflict in multimethod: cannot prefer %s over its descendant %s." + x y)))) + (update prefs x #(conj (set %) y))) + +(defn prefer-method + "Prefer `dispatch-val-x` over `dispatch-val-y` for dispatch and method combinations." + [multifn dispatch-val-x dispatch-val-y] + {:pre [(some? multifn)]} + (when (= dispatch-val-x dispatch-val-y) + (throw (IllegalStateException. (format "Cannot prefer dispatch value %s over itself." dispatch-val-x)))) + (let [prefs (i/prefers multifn)] + (when (contains? (get prefs dispatch-val-y) dispatch-val-x) + (throw (IllegalStateException. (format "Preference conflict in multimethod: %s is already preferred to %s" + dispatch-val-y + dispatch-val-x)))) + (when (i/dominates? (i/with-prefers multifn nil) dispatch-val-y dispatch-val-x) + (throw (IllegalStateException. + (format "Preference conflict in multimethod: cannot prefer %s over its descendant %s." + dispatch-val-x + dispatch-val-y)))) + (let [new-prefs (update prefs dispatch-val-x #(conj (set %) dispatch-val-y))] + (i/with-prefers multifn new-prefs)))) + ;;;; #### Low-level destructive operations @@ -256,6 +292,11 @@ [multifn-var] (alter-var-root+ multifn-var remove-all-methods)) +(defn with-prefers! + "Destructive version of [[methodical.interface/with-prefers]]. Operates on a var defining a Methodical multifn." + [multifn-var new-prefs] + (alter-var-root+ multifn-var i/with-prefers new-prefs)) + (defn prefer-method! "Destructive version of [[prefer-method]]. Operates on a var defining a Methodical multifn. @@ -264,4 +305,4 @@ operation from our nondestructive [[prefer-method]], which returns a copy of the multifn with an altered dispatch table." [multifn-var dispatch-val-x dispatch-val-y] - (alter-var-root+ multifn-var i/prefer-method dispatch-val-x dispatch-val-y)) + (alter-var-root+ multifn-var prefer-method dispatch-val-x dispatch-val-y)) diff --git a/test/methodical/clojure_test.clj b/test/methodical/clojure_test.clj index 6bfae75..15d1ad4 100644 --- a/test/methodical/clojure_test.clj +++ b/test/methodical/clojure_test.clj @@ -1,8 +1,8 @@ (ns methodical.clojure-test "Tests to ensure we can replicate the basic behavior of vanilla Clojure multimethods." (:require [clojure.test :as t] - [methodical.impl :as impl] - [methodical.interface :as i])) + [methodical.core :as m] + [methodical.impl :as impl])) (defn- clojure-multifn [dispatch-fn & options] (impl/multifn (apply impl/clojure-multifn-impl dispatch-fn options))) @@ -10,7 +10,7 @@ (defn- add-methods [multifn fns] (reduce (fn [multifn [dispatch-val f]] - (i/add-primary-method multifn dispatch-val f)) + (m/add-primary-method multifn dispatch-val f)) multifn fns)) @@ -157,8 +157,8 @@ (t/deftest prefer-method-test (with-local-vars [hierarchy (make-ambiguous-hierarchy)] (let [multifn (-> (ambiguous-hierarchy-multifn hierarchy) - (i/prefer-method :parent-1 :parent-2))] - (t/is (= (i/prefers multifn) {:parent-1 #{:parent-2}}) + (m/prefer-method :parent-1 :parent-2))] + (t/is (= (m/prefers multifn) {:parent-1 #{:parent-2}}) "Map of prefers should be visible by calling `prefers`") (t/is (= (multifn :child) :parent-1) "It should be possible to prefer one ambiguous method over another")))) @@ -168,17 +168,17 @@ (let [multifn (ambiguous-hierarchy-multifn hierarchy)] (t/is (thrown-with-msg? IllegalStateException #"Cannot prefer dispatch value :parent-1 over itself" - (i/prefer-method multifn :parent-1 :parent-1)) + (m/prefer-method multifn :parent-1 :parent-1)) "Trying to prefer a dispatch value over itself should throw an Exception") (t/is (thrown-with-msg? IllegalStateException #"Preference conflict in multimethod: :parent-1 is already preferred to :parent-2" (-> multifn - (i/prefer-method :parent-1 :parent-2) - (i/prefer-method :parent-2 :parent-1))) + (m/prefer-method :parent-1 :parent-2) + (m/prefer-method :parent-2 :parent-1))) "You should not be able to prefer something if it would conflict with an existing prefer") (t/is (thrown-with-msg? IllegalStateException #"Preference conflict in multimethod: cannot prefer :parent-1 over its descendant :child" - (i/prefer-method multifn :parent-1 :child)) + (m/prefer-method multifn :parent-1 :child)) "You should not be able to prefer an ancestor over its descendant.")))) (t/deftest remove-primary-method-test @@ -187,11 +187,11 @@ multifn (-> (clojure-multifn keyword) (add-methods {:a a, :default default}))] (t/testing "sanity check" - (t/is (= (i/primary-methods multifn) {:a a, :default default}) + (t/is (= (m/primary-methods multifn) {:a a, :default default}) "You should be able to see a map of dispatch-value -> primary method with `primary-methods`")) (t/testing "remove-primary-method" - (let [multifn (i/remove-primary-method multifn :a)] - (t/is (= (i/primary-methods multifn) {:default default})) + (let [multifn (m/remove-primary-method multifn :a)] + (t/is (= (m/primary-methods multifn) {:default default})) (t/is (= (multifn :a) :default)))))) (t/deftest effective-method-test @@ -202,13 +202,13 @@ :default default-method}))] (t/testing "For Clojure-style multifns, `effective-method` should work just like vanilla `get-method`." (t/is (= (a-method :x) - ((i/effective-method multifn :a) :x)))) + ((m/effective-method multifn :a) :x)))) (t/testing "The default method should be returned if no matching method is found." (t/is (= (default-method :x) - ((i/effective-method multifn :b) :x)))) - (let [multifn (i/remove-primary-method multifn :default)] + ((m/effective-method multifn :b) :x)))) + (let [multifn (m/remove-primary-method multifn :default)] (t/testing "If no default method exists, `effective-method` should return nil if no methods match." (t/is (= nil - (i/effective-method multifn :b))))))) + (m/effective-method multifn :b))))))) ;; TODO - test other methods not available in vanilla Clojure, e.g. `dominates?` and `aux-methods` diff --git a/test/methodical/impl/dispatcher/common_test.clj b/test/methodical/impl/dispatcher/common_test.clj index af53b8a..e376599 100644 --- a/test/methodical/impl/dispatcher/common_test.clj +++ b/test/methodical/impl/dispatcher/common_test.clj @@ -2,30 +2,6 @@ (:require [clojure.test :as t] [methodical.impl.dispatcher.common :as dispatcher.common])) -(t/deftest add-preference-test - (t/is (= {:x #{:y}} - (dispatcher.common/add-preference isa? {} :x :y))) - (t/testing "should thrown an Exception if you try to add an illegal preference" - (t/is (thrown-with-msg? - IllegalStateException - (re-pattern "Cannot prefer dispatch value :x over itself.") - (dispatcher.common/add-preference isa? {} :x :x))) - (t/is (thrown-with-msg? - IllegalStateException - (re-pattern "Preference conflict in multimethod: :x is already preferred to :y") - (dispatcher.common/add-preference isa? {:x #{:y}} :y :x))) - (let [h (-> (make-hierarchy) - (derive :bird :animal) - (derive :toucan :bird)) - isa?* (partial isa? h)] - (doseq [k [:bird :animal]] - (t/testing (format "Prefer %s over :toucan" k) - (t/is (thrown-with-msg? - IllegalStateException - (re-pattern (format "Preference conflict in multimethod: cannot prefer %s over its descendant :toucan." - k)) - (dispatcher.common/add-preference isa?* {} k :toucan)))))))) - (t/deftest prefers-test (t/testing "prefers?" (let [h (-> (make-hierarchy) diff --git a/test/methodical/util_test.clj b/test/methodical/util_test.clj index 0851caa..31bd459 100644 --- a/test/methodical/util_test.clj +++ b/test/methodical/util_test.clj @@ -397,3 +397,29 @@ (t/is (= nil (seq (i/aux-methods remove-all-methods-multifn))))))) + +(t/deftest prefer-method-test + (let [mf (m/default-multifn :k)] + (t/is (= {:x #{:y}} + (i/prefers (u/prefer-method mf :x :y)))) + (t/testing "should thrown an Exception if you try to add an illegal preference" + (t/is (thrown-with-msg? + IllegalStateException + (re-pattern "Cannot prefer dispatch value :x over itself.") + (u/prefer-method mf :x :x))) + (let [mf (i/with-prefers mf {:x #{:y}})] + (t/is (thrown-with-msg? + IllegalStateException + (re-pattern "Preference conflict in multimethod: :x is already preferred to :y") + (u/prefer-method mf :y :x)))) + (let [h (-> (make-hierarchy) + (derive :bird :animal) + (derive :toucan :bird)) + mf2 (m/default-multifn :k :hierarchy (atom h))] + (doseq [k [:bird :animal]] + (t/testing (format "Prefer %s over :toucan" k) + (t/is (thrown-with-msg? + IllegalStateException + (re-pattern (format "Preference conflict in multimethod: cannot prefer %s over its descendant :toucan." + k)) + (u/prefer-method mf2 k :toucan)))))))))