From 5e24b0cb273062d255edb28ac9a5915fb37b0df8 Mon Sep 17 00:00:00 2001 From: Oleksandr Yakushev Date: Wed, 14 Aug 2024 22:55:44 +0300 Subject: [PATCH] Replace Clojure functions that contain metadata with custom FnWithMeta (#150) * Attempt at widening the arities for multimethod calls There's a lot of `apply`/`RestFn`/`invoke` etc. dynamic call machinery in Methodical's stack traces. This is an attempt to remove some of it by going up to 7 direct args for multimethod calls. (And dispatch functions.) This hasn't removed much of the `apply` overhead in practice because `with-meta` on a function wraps it with a naive function subclass that always does a dynamic call. There are probably still some places that more dynamic calls are creeping in, but I ran out of time to dig deeper. This may not go anywhere until I get back, but I wanted to publish this just in case. * Fix tests after widening arities marg * Introduce custom FnWithMeta to attach metadata to functions * Reimplement threaded combinator with explicit first/last separation --------- Co-authored-by: Braden Shepherdson --- .clj-kondo/config.edn | 3 +- src/methodical/impl/combo/clos.clj | 43 ++++-- src/methodical/impl/combo/common.clj | 96 ++++++++++++- src/methodical/impl/combo/threaded.clj | 127 +++++++++--------- src/methodical/impl/dispatcher/everything.clj | 20 +-- .../impl/dispatcher/multi_default.clj | 15 ++- src/methodical/impl/dispatcher/standard.clj | 22 +-- src/methodical/impl/method_table/standard.clj | 9 +- src/methodical/impl/multifn/standard.clj | 3 +- src/methodical/impl/standard.clj | 25 +++- src/methodical/interface.clj | 5 +- src/methodical/macros.clj | 4 +- src/methodical/util.clj | 66 ++++++++- src/methodical/util/trace.clj | 8 +- test/methodical/impl/combo/threaded_test.clj | 27 ---- .../impl/dispatcher/standard_test.clj | 21 +-- .../impl/method_table/standard_test.clj | 11 +- test/methodical/impl/standard_test.clj | 7 +- test/methodical/macros_test.clj | 2 +- test/methodical/test_utils.clj | 9 ++ test/methodical/util/trace_test.clj | 26 ++-- test/methodical/util_test.clj | 57 ++++---- 22 files changed, 394 insertions(+), 212 deletions(-) create mode 100644 test/methodical/test_utils.clj diff --git a/.clj-kondo/config.edn b/.clj-kondo/config.edn index 64d5fdf..caaa7e8 100644 --- a/.clj-kondo/config.edn +++ b/.clj-kondo/config.edn @@ -22,7 +22,8 @@ :unresolved-symbol {:exclude - [(clojure.test/is [macroexpansion-spec-error?])]} + [->FnWithMeta FnWithMeta + (clojure.test/is [macroexpansion-spec-error?])]} :consistent-alias {:aliases diff --git a/src/methodical/impl/combo/clos.clj b/src/methodical/impl/combo/clos.clj index 2449fc4..a184dfc 100644 --- a/src/methodical/impl/combo/clos.clj +++ b/src/methodical/impl/combo/clos.clj @@ -22,34 +22,49 @@ combined-method (fn ([] - (doseq [f befores] - (f)) + (doseq [before befores] + (before)) (combined-method)) ([a] - (doseq [f befores] - (f a)) + (doseq [before befores] + (before a)) (combined-method a)) ([a b] - (doseq [f befores] - (f a b)) + (doseq [before befores] + (before a b)) (combined-method a b)) ([a b c] - (doseq [f befores] - (f a b c)) + (doseq [before befores] + (before a b c)) (combined-method a b c)) ([a b c d] - (doseq [f befores] - (f a b c d)) + (doseq [before befores] + (before a b c d)) (combined-method a b c d)) - ([a b c d & more] - (doseq [f befores] - (apply f a b c d more)) - (apply combined-method a b c d more))))) + ([a b c d e] + (doseq [before befores] + (before a b c d e)) + (combined-method a b c d e)) + + ([a b c d e f] + (doseq [before befores] + (before a b c d e f)) + (combined-method a b c d e f)) + + ([a b c d e f g] + (doseq [before befores] + (before a b c d e f g)) + (combined-method a b c d e f g)) + + ([a b c d e f g & more] + (doseq [before befores] + (apply before a b c d e f g more)) + (apply combined-method a b c d e f g more))))) (defn- apply-afters [combined-method afters] (if (empty? afters) diff --git a/src/methodical/impl/combo/common.clj b/src/methodical/impl/combo/common.clj index 9016967..03351c2 100644 --- a/src/methodical/impl/combo/common.clj +++ b/src/methodical/impl/combo/common.clj @@ -1,5 +1,91 @@ (ns methodical.impl.combo.common - "Utility functions for implementing method combinations.") + "Utility functions for implementing method combinations." + (:require [methodical.util :as u])) + +(defn partial* + "[[clojure.core/partial]] but with more direct arities." + ([inner] inner) + ([inner a] + (fn + ([] (inner a)) + ([p] (inner a p)) + ([p q] (inner a p q)) + ([p q r] (inner a p q r)) + ([p q r s] (inner a p q r s)) + ([p q r s t] (inner a p q r s t)) + ([p q r s t u] (inner a p q r s t u)) + ([p q r s t u v] (inner a p q r s t u v)) + ([p q r s t u v x] (inner a p q r s t u v x)) + ([p q r s t u v x y] (inner a p q r s t u v x y)) + ([p q r s t u v x y & z] (apply inner a p q r s t u v x y z)))) + ([inner a b] + (fn + ([] (inner a b)) + ([p] (inner a b p)) + ([p q] (inner a b p q)) + ([p q r] (inner a b p q r)) + ([p q r s] (inner a b p q r s)) + ([p q r s t] (inner a b p q r s t)) + ([p q r s t u] (inner a b p q r s t u)) + ([p q r s t u v] (inner a b p q r s t u v)) + ([p q r s t u v x] (inner a b p q r s t u v x)) + ([p q r s t u v x y] (inner a b p q r s t u v x y)) + ([p q r s t u v x y & z] (apply inner a b p q r s t u v x y z)))) + ([inner a b c] + (fn + ([] (inner a b c)) + ([p] (inner a b c p)) + ([p q] (inner a b c p q)) + ([p q r] (inner a b c p q r)) + ([p q r s] (inner a b c p q r s)) + ([p q r s t] (inner a b c p q r s t)) + ([p q r s t u] (inner a b c p q r s t u)) + ([p q r s t u v] (inner a b c p q r s t u v)) + ([p q r s t u v x] (inner a b c p q r s t u v x)) + ([p q r s t u v x y] (inner a b c p q r s t u v x y)) + ([p q r s t u v x y & z] (apply inner a b c p q r s t u v x y z)))) + ([inner a b c d] + (fn + ([] (inner a b c d)) + ([p] (inner a b c d p)) + ([p q] (inner a b c d p q)) + ([p q r] (inner a b c d p q r)) + ([p q r s] (inner a b c d p q r s)) + ([p q r s t] (inner a b c d p q r s t)) + ([p q r s t u] (inner a b c d p q r s t u)) + ([p q r s t u v] (inner a b c d p q r s t u v)) + ([p q r s t u v x] (inner a b c d p q r s t u v x)) + ([p q r s t u v x y] (inner a b c d p q r s t u v x y)) + ([p q r s t u v x y & z] (apply inner a b c d p q r s t u v x y z)))) + ([inner a b c d e] + (fn + ([] (inner a b c d e)) + ([p] (inner a b c d e p)) + ([p q] (inner a b c d e p q)) + ([p q r] (inner a b c d e p q r)) + ([p q r s] (inner a b c d e p q r s)) + ([p q r s t] (inner a b c d e p q r s t)) + ([p q r s t u] (inner a b c d e p q r s t u)) + ([p q r s t u v] (inner a b c d e p q r s t u v)) + ([p q r s t u v x] (inner a b c d e p q r s t u v x)) + ([p q r s t u v x y] (inner a b c d e p q r s t u v x y)) + ([p q r s t u v x y & z] (apply inner a e b c d p q r s t u v x y z)))) + ([inner a b c d e f] + (fn + ([] (inner a b c d e f)) + ([p] (inner a b c d e f p)) + ([p q] (inner a b c d e f p q)) + ([p q r] (inner a b c d e f p q r)) + ([p q r s] (inner a b c d e f p q r s)) + ([p q r s t] (inner a b c d e f p q r s t)) + ([p q r s t u] (inner a b c d e f p q r s t u)) + ([p q r s t u v] (inner a b c d e f p q r s t u v)) + ([p q r s t u v x] (inner a b c d e f p q r s t u v x)) + ([p q r s t u v x y] (inner a b c d e f p q r s t u v x y)) + ([p q r s t u v x y & z] (apply inner a e f b c d p q r s t u v x y z)))) + ([inner a b c d e f & more] + (fn [& args] + (inner a b c d e f (concat more args))))) (defn combine-primary-methods "Combine all `primary-methods` into a single combined method. Each method is partially bound with a `next-method` @@ -8,7 +94,8 @@ (when (seq primary-methods) (reduce (fn [next-method primary-method] - (with-meta (partial primary-method next-method) (meta primary-method))) + (u/fn-with-meta (partial* (u/unwrap-fn-with-meta primary-method) next-method) + (meta primary-method))) nil (reverse primary-methods)))) @@ -19,7 +106,8 @@ [combined-method around-methods] (reduce (fn [combined-method around-method] - (with-meta (partial around-method combined-method) (meta around-method))) + (u/fn-with-meta (partial* (u/unwrap-fn-with-meta around-method) combined-method) + (meta around-method))) combined-method around-methods)) @@ -36,7 +124,7 @@ (apply f fn-tail) (vector? (ffirst fn-tail)) - (map (partial transform-fn-tail f) fn-tail) + (map (partial* transform-fn-tail f) fn-tail) :else (throw (ex-info (format "Invalid fn tail: %s. Expected ([arg*] & body) or (([arg*] & body)+)" diff --git a/src/methodical/impl/combo/threaded.clj b/src/methodical/impl/combo/threaded.clj index ccd8962..ad21e26 100644 --- a/src/methodical/impl/combo/threaded.clj +++ b/src/methodical/impl/combo/threaded.clj @@ -4,6 +4,7 @@ [clojure.core.protocols :as clojure.protocols] [methodical.impl.combo.common :as combo.common] [methodical.interface] + [methodical.util :as u] [methodical.util.describe :as describe] [pretty.core :as pretty]) (:import @@ -13,71 +14,61 @@ (comment methodical.interface/keep-me) -(defn reducer-fn - "Reduces a series of before/combined-primary/after methods, threading the resulting values to the next method by - calling the `invoke` function, which is generated by `threaded-invoker`." - [before-primary-after-methods] - (fn [[initial-value invoke]] - (reduce - (fn [last-result method] - (invoke method last-result)) - initial-value - before-primary-after-methods))) - -(defn combine-with-threader - "Combine primary and auxiliary methods using a threading invoker, i.e. something you'd get by calling - `threading-invoker`. The way these methods are combined/reduced is the same, regardless of how args are threaded; - thus, various strategies such as `:thread-first` and `:thread-last` can both share the same `reducer-fn`." - ([threader before-primary-afters] - (comp (reducer-fn before-primary-afters) threader)) - - ([threader primary-methods {:keys [before after around]}] - (when-let [primary (combo.common/combine-primary-methods primary-methods)] - (let [methods (concat before [primary] (reverse after)) - threaded-fn (combine-with-threader threader methods) - optimized-one-arg-fn (apply comp (reverse methods))] - (combo.common/apply-around-methods - (-> (fn - ([] (optimized-one-arg-fn)) - ([a] (optimized-one-arg-fn a)) - ([a b] (threaded-fn a b)) - ([a b c] (threaded-fn a b c)) - ([a b c d] (threaded-fn a b c d)) - ([a b c d & more] (apply threaded-fn a b c d more))) - (vary-meta assoc :methodical/combined-method? true)) - around))))) - -(defmulti threading-invoker - "Define a new 'threading invoker', which define how before/combined-primary/after methods should thread values to - subsequent methods. These methods take the initial values used to invoke a multifn, then return a pair like - `[initial-value threading-fn]`. The threading function is used to invoke any subsequent methods using only q single - value, the result of the previous method; if effectively partially binds subsequent methods so that they are always - invoked with the initial values of this invocation, excluding the threaded value." - {:arglists '([threading-type])} - keyword) - -(defmethod threading-invoker :thread-first - [_] - (fn - ([a b] [a (fn [method a*] (method a* b))]) - ([a b c] [a (fn [method a*] (method a* b c))]) - ([a b c d] [a (fn [method a*] (method a* b c d))]) - ([a b c d & more] [a (fn [method a*] (apply method a* b c d more))]))) - -(defmethod threading-invoker :thread-last - [_] - (fn - ([a b] [b (fn [method b*] (method a b*))]) - ([a b c] [c (fn [method c*] (method a b c*))]) - ([a b c d] [d (fn [method d*] (method a b c d*))]) - - ([a b c d & more] - (let [last-val (last more) - butlast* (vec (concat [a b c d] (butlast more)))] - [last-val - (fn [method last*] - (apply method (conj butlast* last*)))])))) - +(defn combine-methods-thread-first + "Combine primary and auxiliary methods using a thread-first threading type." + [primary-methods {:keys [before after around]}] + (when-let [primary (combo.common/combine-primary-methods primary-methods)] + (combo.common/apply-around-methods + (if (and (empty? before) (empty? after)) + ;; If there is only the combined primary method, skip the wrapping dance and just return it. + primary + + (let [methods (concat before [primary] (reverse after))] + (-> (reduce + (fn [current nxt] + (let [nxt (u/unwrap-fn-with-meta nxt)] + (fn combined-method-thread-first + ([] (current) (nxt)) + ([a] (nxt (current a))) + ([a b] (nxt (current a b) b)) + ([a b c] (nxt (current a b c) b c)) + ([a b c d] (nxt (current a b c d) b c d)) + ([a b c d e] (nxt (current a b c d e) b c d e)) + ([a b c d e f] (nxt (current a b c d e f) b c d e f)) + ([a b c d e f g] (nxt (current a b c d e f g) b c d e f g)) + ([a b c d e f g & more] (apply nxt (apply current a b c d e f g more) b c d e f g more))))) + (u/unwrap-fn-with-meta (first methods)) + (rest methods)) + (u/fn-vary-meta assoc :methodical/combined-method? true)))) + around))) + +(defn combine-methods-thread-last + "Combine primary and auxiliary methods using a thread-last threading type." + [primary-methods {:keys [before after around]}] + (when-let [primary (combo.common/combine-primary-methods primary-methods)] + (combo.common/apply-around-methods + (if (and (empty? before) (empty? after)) + ;; If there is only the combined primary method, skip the wrapping dance and just return it. + primary + + (let [methods (concat before [primary] (reverse after))] + (-> (reduce + (fn [current nxt] + (let [nxt (u/unwrap-fn-with-meta nxt)] + (fn combined-method-thread-last + ([] (current) (nxt)) + ([a] (nxt (current a))) + ([a b] (nxt a (current a b))) + ([a b c] (nxt a b (current a b c))) + ([a b c d] (nxt a b c (current a b c d))) + ([a b c d e] (nxt a b c d (current a b c d e))) + ([a b c d e f] (nxt a b c d e (current a b c d e f))) + ([a b c d e f g] (nxt a b c d e f (current a b c d e f g))) + ([a b c d e f g & more] (apply nxt a b c d e f g (concat (butlast more) [(apply current a b c d e f g more)])))))) + (u/unwrap-fn-with-meta (first methods)) + (rest methods)) + (u/fn-vary-meta assoc :methodical/combined-method? true)))) + around))) (deftype ThreadingMethodCombination [threading-type] pretty/PrettyPrintable @@ -95,7 +86,9 @@ #{nil :before :after :around}) (combine-methods [_ primary-methods aux-methods] - (combine-with-threader (threading-invoker threading-type) primary-methods aux-methods)) + (case threading-type + :thread-first (combine-methods-thread-first primary-methods aux-methods) + :thread-last (combine-methods-thread-last primary-methods aux-methods))) (transform-fn-tail [_ qualifier fn-tail] (combo.common/add-implicit-next-method-args qualifier fn-tail)) @@ -115,5 +108,5 @@ "Create a new `ThreadingMethodCombination` using the keyword `threading-type` strategy, e.g. `:thread-first` or `:thread-last`." [threading-type] - {:pre [(get-method threading-invoker threading-type)]} + {:pre [(#{:thread-first :thread-last} threading-type)]} (ThreadingMethodCombination. threading-type)) diff --git a/src/methodical/impl/dispatcher/everything.clj b/src/methodical/impl/dispatcher/everything.clj index dd41c0e..2aa223b 100644 --- a/src/methodical/impl/dispatcher/everything.clj +++ b/src/methodical/impl/dispatcher/everything.clj @@ -4,6 +4,7 @@ [clojure.core.protocols :as clojure.protocols] [methodical.impl.dispatcher.common :as dispatcher.common] [methodical.interface :as i] + [methodical.util :as u] [methodical.util.describe :as describe] [pretty.core :as pretty]) (:import @@ -32,18 +33,21 @@ (= prefs (.prefs another)))))) Dispatcher - (dispatch-value [_] nil) - (dispatch-value [_ _a] nil) - (dispatch-value [_ _a _b] nil) - (dispatch-value [_ _a _b _c] nil) - (dispatch-value [_ _a _b _c _d] nil) - (dispatch-value [_ _a _b _c _d _more] nil) + (dispatch-value [_] nil) + (dispatch-value [_ _a] nil) + (dispatch-value [_ _a _b] nil) + (dispatch-value [_ _a _b _c] nil) + (dispatch-value [_ _a _b _c _d] nil) + (dispatch-value [_ _a _b _c _d _e] nil) + (dispatch-value [_ _a _b _c _d _e _f] nil) + (dispatch-value [_ _a _b _c _d _e _f _g] nil) + (dispatch-value [_ _a _b _c _d _e _f _g _more] nil) (matching-primary-methods [_ method-table _] (let [primary-methods (i/primary-methods method-table) comparatorr (dispatcher.common/domination-comparator (deref hierarchy-var) prefs)] (for [[dispatch-value method] (sort-by first comparatorr primary-methods)] - (vary-meta method assoc :dispatch-value dispatch-value)))) + (u/fn-vary-meta method assoc :dispatch-value dispatch-value)))) (matching-aux-methods [_ method-table _] (let [aux-methods (i/aux-methods method-table) @@ -51,7 +55,7 @@ (into {} (for [[qualifier dispatch-value->methods] aux-methods] [qualifier (for [[dispatch-value methods] (sort-by first comparatorr dispatch-value->methods) method methods] - (vary-meta method assoc :dispatch-value dispatch-value))])))) + (u/fn-vary-meta method assoc :dispatch-value dispatch-value))])))) (default-dispatch-value [_] nil) diff --git a/src/methodical/impl/dispatcher/multi_default.clj b/src/methodical/impl/dispatcher/multi_default.clj index c6387e3..4ae3465 100644 --- a/src/methodical/impl/dispatcher/multi_default.clj +++ b/src/methodical/impl/dispatcher/multi_default.clj @@ -155,12 +155,15 @@ (= prefs (.prefs another)))))) Dispatcher - (dispatch-value [_] (dispatch-fn)) - (dispatch-value [_ a] (dispatch-fn a)) - (dispatch-value [_ a b] (dispatch-fn a b)) - (dispatch-value [_ a b c] (dispatch-fn a b c)) - (dispatch-value [_ a b c d] (dispatch-fn a b c d)) - (dispatch-value [_ a b c d more] (apply dispatch-fn a b c d more)) + (dispatch-value [_] (dispatch-fn)) + (dispatch-value [_ a] (dispatch-fn a)) + (dispatch-value [_ a b] (dispatch-fn a b)) + (dispatch-value [_ a b c] (dispatch-fn a b c)) + (dispatch-value [_ a b c d] (dispatch-fn a b c d)) + (dispatch-value [_ a b c d e] (dispatch-fn a b c d e)) + (dispatch-value [_ a b c d e f] (dispatch-fn a b c d e f)) + (dispatch-value [_ a b c d e f g] (dispatch-fn a b c d e f g)) + (dispatch-value [_ a b c d e f g more] (apply dispatch-fn a b c d e f g more)) (matching-primary-methods [_ method-table dispatch-value] (matching-primary-methods diff --git a/src/methodical/impl/dispatcher/standard.clj b/src/methodical/impl/dispatcher/standard.clj index f6368cb..036aa98 100644 --- a/src/methodical/impl/dispatcher/standard.clj +++ b/src/methodical/impl/dispatcher/standard.clj @@ -6,6 +6,7 @@ [clojure.core.protocols :as clojure.protocols] [methodical.impl.dispatcher.common :as dispatcher.common] [methodical.interface :as i] + [methodical.util :as u] [methodical.util.describe :as describe] [pretty.core :as pretty]) (:import @@ -71,10 +72,10 @@ (get (i/primary-methods method-table) default-value))] (concat (for [[dispatch-value method] pairs] - (vary-meta method assoc :dispatch-value dispatch-value)) + (u/fn-vary-meta method assoc :dispatch-value dispatch-value)) (when (and default-method (not (contains? (set (map first pairs)) default-value))) - [(vary-meta default-method assoc :dispatch-value default-value)])))) + [(u/fn-vary-meta default-method assoc :dispatch-value default-value)])))) (defn- matching-aux-pairs-excluding-default "Return pairs of `[dispatch-value method]` of applicable aux methods, *excluding* default aux methods. Pairs are @@ -106,7 +107,7 @@ :let [pairs (matching-aux-pairs qualifier opts)] :when (seq pairs)] [qualifier (for [[dispatch-value method] pairs] - (vary-meta method assoc :dispatch-value dispatch-value))]))) + (u/fn-vary-meta method assoc :dispatch-value dispatch-value))]))) (deftype StandardDispatcher [dispatch-fn hierarchy-var default-value prefs] pretty/PrettyPrintable @@ -131,12 +132,15 @@ (= prefs (.prefs another)))))) Dispatcher - (dispatch-value [_] (dispatch-fn)) - (dispatch-value [_ a] (dispatch-fn a)) - (dispatch-value [_ a b] (dispatch-fn a b)) - (dispatch-value [_ a b c] (dispatch-fn a b c)) - (dispatch-value [_ a b c d] (dispatch-fn a b c d)) - (dispatch-value [_ a b c d more] (apply dispatch-fn a b c d more)) + (dispatch-value [_] (dispatch-fn)) + (dispatch-value [_ a] (dispatch-fn a)) + (dispatch-value [_ a b] (dispatch-fn a b)) + (dispatch-value [_ a b c] (dispatch-fn a b c)) + (dispatch-value [_ a b c d] (dispatch-fn a b c d)) + (dispatch-value [_ a b c d e] (dispatch-fn a b c d e)) + (dispatch-value [_ a b c d e f] (dispatch-fn a b c d e f)) + (dispatch-value [_ a b c d e f g] (dispatch-fn a b c d e f g)) + (dispatch-value [_ a b c d e f g more] (apply dispatch-fn a b c d e f g more)) (matching-primary-methods [_ method-table dispatch-value] (matching-primary-methods diff --git a/src/methodical/impl/method_table/standard.clj b/src/methodical/impl/method_table/standard.clj index 4aa1266..38d144c 100644 --- a/src/methodical/impl/method_table/standard.clj +++ b/src/methodical/impl/method_table/standard.clj @@ -3,6 +3,7 @@ [clojure.core.protocols :as clojure.protocols] [methodical.impl.method-table.common :as method-table.common] [methodical.interface] + [methodical.util :as u] [methodical.util.describe :as describe] [pretty.core :as pretty]) (:import @@ -49,7 +50,7 @@ aux) (add-primary-method [this dispatch-val method] - (let [new-primary (assoc primary dispatch-val (vary-meta method assoc :dispatch-value dispatch-val))] + (let [new-primary (assoc primary dispatch-val (u/fn-vary-meta method assoc :dispatch-value dispatch-val))] (if (= primary new-primary) this (StandardMethodTable. new-primary aux)))) @@ -67,7 +68,7 @@ (if (contains? (set existing-methods) method) existing-methods (conj (vec existing-methods) - (vary-meta method assoc :dispatch-value dispatch-value)))))] + (u/fn-vary-meta method assoc :dispatch-value dispatch-value)))))] (if (= aux new-aux) this (StandardMethodTable. primary new-aux)))) @@ -75,7 +76,9 @@ (remove-aux-method [this qualifier dispatch-value method] (let [xforms [(fn [aux] (update-in aux [qualifier dispatch-value] (fn [defined-methods] - (remove #(= % method) defined-methods)))) + (remove #(or (= % method) + (= (u/unwrap-fn-with-meta %) method)) + defined-methods)))) (fn [aux] (cond-> aux (empty? (get-in aux [qualifier dispatch-value])) diff --git a/src/methodical/impl/multifn/standard.clj b/src/methodical/impl/multifn/standard.clj index f40104e..6157bd5 100644 --- a/src/methodical/impl/multifn/standard.clj +++ b/src/methodical/impl/multifn/standard.clj @@ -5,6 +5,7 @@ [clojure.datafy :as datafy] [methodical.impl.dispatcher.common :as dispatcher.common] [methodical.interface :as i] + [methodical.util :as u] [methodical.util.describe :as describe] [pretty.core :as pretty]) (:import @@ -102,7 +103,7 @@ (let [primary-methods (i/matching-primary-methods dispatcher method-table dispatch-value) aux-methods (i/matching-aux-methods dispatcher method-table dispatch-value)] (some-> (i/combine-methods method-combination primary-methods aux-methods) - (with-meta {:dispatch-value (effective-dispatch-value dispatcher dispatch-value primary-methods aux-methods)})))) + (u/fn-with-meta {:dispatch-value (effective-dispatch-value dispatcher dispatch-value primary-methods aux-methods)})))) (deftype StandardMultiFnImpl [^MethodCombination combo ^Dispatcher dispatcher diff --git a/src/methodical/impl/standard.clj b/src/methodical/impl/standard.clj index 924efd8..f71b597 100644 --- a/src/methodical/impl/standard.clj +++ b/src/methodical/impl/standard.clj @@ -60,9 +60,20 @@ ([^MultiFnImpl impl mta a b c d] (invoke-multi impl mta a b c d)) - ([^MultiFnImpl impl mta a b c d & more] + ([^MultiFnImpl impl mta a b c d e] + #_(println "invoke-multifn 5-arity") + (invoke-multi impl mta a b c d e)) + + ([^MultiFnImpl impl mta a b c d e f] + (invoke-multi impl mta a b c d e f)) + + ([^MultiFnImpl impl mta a b c d e f g] + (invoke-multi impl mta a b c d e f g)) + + ([^MultiFnImpl impl mta a b c d e f g & more] ;; TODO: possible to use the macro somehow in this case? - (try (apply (effective-method impl (.dispatch-value ^Dispatcher (.dispatcher impl) a b c d more)) a b c d more) + (try (apply (effective-method impl (.dispatch-value ^Dispatcher (.dispatcher impl) a b c d e f g more)) + a b c d e f g more) (catch Exception e (handle-effective-method-exception e mta))))) @@ -109,8 +120,14 @@ (.dispatch-value ^Dispatcher (.dispatcher impl) a b c)) (dispatch-value [_ a b c d] (.dispatch-value ^Dispatcher (.dispatcher impl) a b c d)) - (dispatch-value [_ a b c d more] - (.dispatch-value ^Dispatcher (.dispatcher impl) a b c d more)) + (dispatch-value [_ a b c d e] + (.dispatch-value ^Dispatcher (.dispatcher impl) a b c d e)) + (dispatch-value [_ a b c d e f] + (.dispatch-value ^Dispatcher (.dispatcher impl) a b c d e f)) + (dispatch-value [_ a b c d e f g] + (.dispatch-value ^Dispatcher (.dispatcher impl) a b c d e f g)) + (dispatch-value [_ a b c d e f g more] + (.dispatch-value ^Dispatcher (.dispatcher impl) a b c d e f g more)) (matching-primary-methods [_ method-table dispatch-value] (i/matching-primary-methods (.dispatcher impl) method-table dispatch-value)) diff --git a/src/methodical/interface.clj b/src/methodical/interface.clj index 7d491fb..d0be981 100644 --- a/src/methodical/interface.clj +++ b/src/methodical/interface.clj @@ -72,7 +72,10 @@ [dispatcher a b] [dispatcher a b c] [dispatcher a b c d] - [dispatcher a b c d more] + [dispatcher a b c d e] + [dispatcher a b c d e f] + [dispatcher a b c d e f g] + [dispatcher a b c d e f g more] "Return an appropriate dispatch value for args passed to a multimethod. (This method is equivalent in purpose to the dispatch function of vanilla Clojure multimethods.)") diff --git a/src/methodical/macros.clj b/src/methodical/macros.clj index cc7b033..51778df 100644 --- a/src/methodical/macros.clj +++ b/src/methodical/macros.clj @@ -322,7 +322,7 @@ ~@(when docstring [docstring]) ~@(i/transform-fn-tail multifn nil fn-tail)) - (u/add-primary-method! (var ~multifn-symb) ~dispatch-value (vary-meta ~fn-symb merge (meta (var ~fn-symb))))))) + (u/add-primary-method! (var ~multifn-symb) ~dispatch-value (u/fn-vary-meta ~fn-symb merge (meta (var ~fn-symb))))))) (defn- emit-aux-method "Impl for [[defmethod]] for aux methods." @@ -337,7 +337,7 @@ (u/add-aux-method-with-unique-key! (var ~multifn-symb) ~qualifier ~dispatch-value - (vary-meta ~fn-symb merge (meta (var ~fn-symb))) + (u/fn-vary-meta ~fn-symb merge (meta (var ~fn-symb))) ~unique-key)))) (defn- defmethod-args-spec [multifn] diff --git a/src/methodical/util.clj b/src/methodical/util.clj index 1774238..384090a 100644 --- a/src/methodical/util.clj +++ b/src/methodical/util.clj @@ -14,6 +14,55 @@ [x] (impl.standard/multifn? x)) +(declare unwrap-fn-with-meta) + +(defmacro generate-FnWithMeta + "Generate FnWithMeta deftype declaration." + [] + (let [make-args (fn [arity] + (mapv #(symbol (str "a" (inc %))) + (range 0 arity)))] + `(deftype ~'FnWithMeta [~(with-meta 'fn {:tag 'clojure.lang.IFn}) ~'mta] + ~'Object + (~'equals [~'_ ~'o] + (= ~'fn (unwrap-fn-with-meta ~'o))) + + clojure.lang.IObj + (~'meta [~'_] ~'mta) + (~'withMeta [~'_ ~'newMta] (~'FnWithMeta. ~'fn ~'newMta)) + + clojure.lang.Fn + clojure.lang.IFn + ~@(for [arity (range 0 21)] + (let [args (make-args arity)] + (list 'invoke (vec (cons '_ args)) + (list* '.invoke 'fn args)))) + (~'invoke ~(vec (cons '_ (conj (make-args 20) 'rest))) + (~'.invoke ~'fn ~(conj (make-args 20) 'rest))) + + (~'applyTo [~'_ ~'arglist] + (clojure.lang.AFn/applyToHelper ~'fn ~'arglist))))) + +(generate-FnWithMeta) + +(defn unwrap-fn-with-meta + "If the provided argument is a FnWithMeta object, extract the function it wraps, otherwise return the argument." + [fun] + (if (instance? FnWithMeta fun) + (.fn ^FnWithMeta fun) + fun)) + +(defn fn-with-meta + "Construct a new FnWithMeta from the provided arguments. Unwrap `fun` if it an FnWithMeta too." + [fun mta] + (->FnWithMeta (unwrap-fn-with-meta fun) mta)) + +(defn fn-vary-meta + "Construct a new FnWithMeta with the same underlying function (possibly unwrapped) but with the meta that is the result + of `(apply f (meta obj) args)`." + [fun f & args] + (fn-with-meta (unwrap-fn-with-meta fun) (apply f (meta fun) args))) + (defn primary-method "Get the primary method *explicitly specified* for `dispatch-value`. This function does not return methods that would otherwise still be applicable (e.g., methods for ancestor dispatch values) -- just the methods explicitly defined @@ -51,7 +100,7 @@ [multifn dispatch-val] (let [[most-specific-primary-method :as primary-methods] (matching-primary-methods multifn dispatch-val)] (some-> (i/combine-methods multifn primary-methods nil) - (with-meta (meta most-specific-primary-method))))) + (fn-with-meta (meta most-specific-primary-method))))) (defn aux-methods "Get all auxiliary methods *explicitly specified* for `dispatch-value`. This function does not include methods that @@ -112,11 +161,14 @@ ;; since protocols can't define varargs, we have to wrap the `dispatch-value` method from the protocol and apply ;; varargs for > 4 args. The various < 4 args arities are there as an optimization because it's a little faster than ;; calling apply every time. - ([multifn a] (i/dispatch-value multifn a)) - ([multifn a b] (i/dispatch-value multifn a b)) - ([multifn a b c] (i/dispatch-value multifn a b c)) - ([multifn a b c d] (i/dispatch-value multifn a b c d)) - ([multifn a b c d & more] (i/dispatch-value multifn a b c d more))) + ([multifn a] (i/dispatch-value multifn a)) + ([multifn a b] (i/dispatch-value multifn a b)) + ([multifn a b c] (i/dispatch-value multifn a b c)) + ([multifn a b c d] (i/dispatch-value multifn a b c d)) + ([multifn a b c d e] (i/dispatch-value multifn a b c d e)) + ([multifn a b c d e f] (i/dispatch-value multifn a b c d e f)) + ([multifn a b c d e f g] (i/dispatch-value multifn a b c d e f g)) + ([multifn a b c d e f g & more] (i/dispatch-value multifn a b c d e f g more))) (defn dispatch-fn "Return a function that can be used to calculate dispatch values of given arg(s)." @@ -183,7 +235,7 @@ {:pre [(some? multifn)]} (-> multifn (remove-aux-method-with-unique-key qualifier dispatch-val unique-key) - (i/add-aux-method qualifier dispatch-val (vary-meta f assoc :methodical/unique-key unique-key)))) + (i/add-aux-method qualifier dispatch-val (fn-vary-meta f assoc :methodical/unique-key unique-key)))) (defn remove-all-methods "Remove all primary and auxiliary methods, including default implementations." diff --git a/src/methodical/util/trace.clj b/src/methodical/util/trace.clj index a090866..c6d9b71 100644 --- a/src/methodical/util/trace.clj +++ b/src/methodical/util/trace.clj @@ -92,19 +92,19 @@ (defn- trace-primary-method [primary-method] (-> (trace-method primary-method) - (with-meta (meta primary-method)))) + (u/fn-with-meta (meta primary-method)))) (defn- trace-primary-methods [primary-methods] (map trace-primary-method primary-methods)) (defn- trace-aux-method [aux-method] (-> (trace-method aux-method) - (with-meta (meta aux-method)))) + (u/fn-with-meta (meta aux-method)))) (defn- trace-aux-methods [qualifier->ms] (into {} (for [[qualifier aux-methods] qualifier->ms] [qualifier (for [aux-method aux-methods] - (trace-aux-method (vary-meta aux-method assoc :qualifier qualifier)))]))) + (trace-aux-method (u/fn-vary-meta aux-method assoc :qualifier qualifier)))]))) (defn trace* "Function version of [[trace]] macro. The only difference is this doesn't capture the form of `multifn` passed to @@ -114,7 +114,7 @@ primary-methods (trace-primary-methods (u/matching-primary-methods multifn dispatch-value)) aux-methods (trace-aux-methods (u/matching-aux-methods multifn dispatch-value)) combined (-> (i/combine-methods multifn primary-methods aux-methods) - (with-meta (meta multifn)) + (u/fn-with-meta (meta multifn)) trace-method)] (apply combined args))) diff --git a/test/methodical/impl/combo/threaded_test.clj b/test/methodical/impl/combo/threaded_test.clj index 7a2b709..0420667 100644 --- a/test/methodical/impl/combo/threaded_test.clj +++ b/test/methodical/impl/combo/threaded_test.clj @@ -3,33 +3,6 @@ [methodical.impl.combo.threaded :as combo.threaded] [methodical.interface :as i])) -(t/deftest threading-invoker-test - (t/are [threading expected-2 expected-3 expected-4 expected-5] - (let [invoker (comp second (combo.threaded/threading-invoker threading))] - (t/is (= expected-2 - ((invoker :a :b) list 'acc))) - - (t/is (= expected-3 - ((invoker :a :b :c) list 'acc))) - - (t/is (= expected-4 - ((invoker :a :b :c :d) list 'acc))) - - (t/is (= expected-5 - ((invoker :a :b :c :d :e) list 'acc)))) - - :thread-first - ['acc :b] - ['acc :b :c] - ['acc :b :c :d] - ['acc :b :c :d :e] - - :thread-last - [:a 'acc] - [:a :b 'acc] - [:a :b :c 'acc] - [:a :b :c :d 'acc])) - (defn- combine-methods [threading-type primary-methods aux-methods] (i/combine-methods (combo.threaded/threading-method-combination threading-type) primary-methods aux-methods)) diff --git a/test/methodical/impl/dispatcher/standard_test.clj b/test/methodical/impl/dispatcher/standard_test.clj index b651d01..bc65a56 100644 --- a/test/methodical/impl/dispatcher/standard_test.clj +++ b/test/methodical/impl/dispatcher/standard_test.clj @@ -3,7 +3,8 @@ [clojure.test :as t] [methodical.core :as m] [methodical.impl :as impl] - [methodical.interface :as i]) + [methodical.interface :as i] + [methodical.test-utils :as tu]) (:import (methodical.interface MethodTable))) @@ -32,10 +33,10 @@ (t/testing "matching-primary-methods should return all matches in order of specificity." (let [method-table (method-table {:child 'child, :parent 'parent, :grandparent 'grandparent} nil)] (t/is (= '[child parent grandparent] - (i/matching-primary-methods dispatcher method-table :child))) + (tu/unwrap-fns-with-meta (i/matching-primary-methods dispatcher method-table :child)))) (t/is (= '[parent grandparent] - (i/matching-primary-methods dispatcher method-table :parent))))) + (tu/unwrap-fns-with-meta (i/matching-primary-methods dispatcher method-table :parent)))))) (t/testing "default primary methods" (let [method-table (method-table {:child 'child @@ -44,14 +45,14 @@ :default 'default} nil)] (t/testing "default methods should be included if they exist" (t/is (= '[parent grandparent default] - (i/matching-primary-methods dispatcher method-table :parent))) + (tu/unwrap-fns-with-meta (i/matching-primary-methods dispatcher method-table :parent)))) (t/testing "should return ^:dispatch-value metadata" (t/is (= [{:dispatch-value :parent} {:dispatch-value :grandparent} {:dispatch-value :default}] (map meta (i/matching-primary-methods dispatcher method-table :parent)))))) (t/testing "If there are otherwise no matches, default should be returned (but nothing else)" (t/is (= '[default] - (i/matching-primary-methods dispatcher method-table :cousin))) + (tu/unwrap-fns-with-meta (i/matching-primary-methods dispatcher method-table :cousin)))) (t/testing "should return ^:dispatch-value metadata" (t/is (= [{:dispatch-value :default}] (map meta (i/matching-primary-methods dispatcher method-table :cousin)))))) @@ -61,7 +62,7 @@ :hierarchy #'basic-hierarchy :default-value :grandparent)] (t/is (= '[parent grandparent] - (i/matching-primary-methods dispatcher-with-custom-default method-table :parent))) + (tu/unwrap-fns-with-meta (i/matching-primary-methods dispatcher-with-custom-default method-table :parent)))) (t/testing "should return ^:dispatch-value metadata" (t/is (= [{:dispatch-value :parent} {:dispatch-value :grandparent}] (map meta (i/matching-primary-methods @@ -82,7 +83,7 @@ (let [dispatcher (impl/standard-dispatcher keyword :hierarchy #'basic-hierarchy)] (t/is (= {:before '[default]} - (i/matching-aux-methods dispatcher method-table :cousin))) + (tu/unwrap-fns-with-meta (i/matching-aux-methods dispatcher method-table :cousin)))) (t/testing "should return ^:dispatch-value metadata" (t/is (= {:before [{:dispatch-value :default}]} (aux-methods-metadata (i/matching-aux-methods dispatcher method-table :cousin))))))) @@ -92,7 +93,7 @@ :hierarchy #'basic-hierarchy :default-value :grandparent)] (t/is (= {:before '[parent grandparent]} - (i/matching-aux-methods dispatcher method-table :parent))) + (tu/unwrap-fns-with-meta (i/matching-aux-methods dispatcher method-table :parent)))) (t/testing "should return ^:dispatch-value metadata" (t/is (= {:before [{:dispatch-value :parent} {:dispatch-value :grandparent}]} (aux-methods-metadata (i/matching-aux-methods dispatcher method-table :parent)))))))))) @@ -130,10 +131,10 @@ (catch Exception e (t/is (= {:method-1 {:ns (the-ns 'methodical.impl.dispatcher.standard-test) :file "methodical/impl/dispatcher/standard_test.clj" - :line 106 + :line 107 :dispatch-value ::parrot} :method-2 {:ns (the-ns 'methodical.impl.dispatcher.standard-test) :file "methodical/impl/dispatcher/standard_test.clj" - :line 110 + :line 111 :dispatch-value ::friend}} (ex-data e)))))))) diff --git a/test/methodical/impl/method_table/standard_test.clj b/test/methodical/impl/method_table/standard_test.clj index 082f4a9..69e8fcf 100644 --- a/test/methodical/impl/method_table/standard_test.clj +++ b/test/methodical/impl/method_table/standard_test.clj @@ -3,7 +3,8 @@ [clojure.test :as t] [clojure.tools.reader.edn :as edn] [methodical.impl.method-table.standard :as method-table.standard] - [methodical.interface :as i])) + [methodical.interface :as i] + [methodical.test-utils :as tu])) (t/deftest print-test (t/is (= "(standard-method-table)" @@ -32,17 +33,17 @@ (i/add-aux-method :before :x 'f))] (t/testing "primary method" (t/is (= {[:x :y] 'f} - (i/primary-methods table))) + (tu/unwrap-fns-with-meta (i/primary-methods table)))) (let [method (-> (i/primary-methods table) vals first)] (t/is (= 'f - method)) + (tu/unwrap-fns-with-meta method))) (t/is (= {:dispatch-value [:x :y]} (meta method))))) (t/testing "aux method" (let [method (-> (i/aux-methods table) :before vals ffirst)] (t/is (= {:before {:x ['f]}} - (i/aux-methods table))) + (tu/unwrap-fns-with-meta (i/aux-methods table)))) (t/is (= 'f - method)) + (tu/unwrap-fns-with-meta method))) (t/is (= {:dispatch-value :x} (meta method)))))))) diff --git a/test/methodical/impl/standard_test.clj b/test/methodical/impl/standard_test.clj index 937177b..df8ae24 100644 --- a/test/methodical/impl/standard_test.clj +++ b/test/methodical/impl/standard_test.clj @@ -176,5 +176,8 @@ 2 (i/dispatch-value f :a :b) 3 (i/dispatch-value f :a :b :c) 4 (i/dispatch-value f :a :b :c :d) - 5 (i/dispatch-value f :a :b :c :d [:e]) - 6 (i/dispatch-value f :a :b :c :d [:e :f])))) + 5 (i/dispatch-value f :a :b :c :d :e) + 6 (i/dispatch-value f :a :b :c :d :e :f) + 7 (i/dispatch-value f :a :b :c :d :e :f :g) + 8 (i/dispatch-value f :a :b :c :d :e :f :g [:h]) + 9 (i/dispatch-value f :a :b :c :d :e :f :g [:h :i])))) diff --git a/test/methodical/macros_test.clj b/test/methodical/macros_test.clj index 472bbe0..97f9a1c 100644 --- a/test/methodical/macros_test.clj +++ b/test/methodical/macros_test.clj @@ -294,7 +294,7 @@ (-> (impl/multifn impl nil (impl/watching-cache (impl/simple-cache) [#'clojure.core/global-hierarchy])) - (i/add-primary-method :x (u/primary-method mf1 :x)))] + (i/add-primary-method :x (u/unwrap-fn-with-meta (u/primary-method mf1 :x))))] (t/testing "Sanity check" (t/testing 'mf1 (t/is (= 1 diff --git a/test/methodical/test_utils.clj b/test/methodical/test_utils.clj new file mode 100644 index 0000000..4785df5 --- /dev/null +++ b/test/methodical/test_utils.clj @@ -0,0 +1,9 @@ +(ns methodical.test-utils + (:require + [clojure.walk :as walk] + [methodical.util :as u])) + +(defn unwrap-fns-with-meta + "Walk the object and unwrap all encountered FnWithMeta's." + [coll] + (walk/postwalk u/unwrap-fn-with-meta coll)) diff --git a/test/methodical/util/trace_test.clj b/test/methodical/util/trace_test.clj index 6e0468c..b4df9ab 100644 --- a/test/methodical/util/trace_test.clj +++ b/test/methodical/util/trace_test.clj @@ -80,17 +80,17 @@ (def ^:private lots-of-args-multifn (-> (m/default-multifn - (fn [a b c d e _f] [a (class b) c d e])) + (fn [a b c d e _f _g _h _i _j] [a (class b) c d e])) (m/add-primary-method :default - (fn [_ a _ _ _ _ f] {:a a, :f f})) + (fn [_ a _ _ _ _ _ _ _ _ j] {:a a, :j j})) (m/add-primary-method [::x :default :default :default :default] - (fn [_ a _ _ _ _ f] {:x a, :f f})))) + (fn [_ a _ _ _ _ _ _ _ _ j] {:x a, :j j})))) (t/deftest lots-of-args-test - (t/testing "> 4 args" - (t/is (= {:x ::x, :f :f} - (lots-of-args-multifn ::x :b :c :d :e :f))) - (t/is (= ["0: (lots-of-args-multifn :methodical.util.trace-test/x :b :c :d :e :f)" + (t/testing "> 7 args" + (t/is (= {:x ::x, :j :j} + (lots-of-args-multifn ::x :b :c :d :e :f :g :h :i :j))) + (t/is (= ["0: (lots-of-args-multifn :methodical.util.trace-test/x :b :c :d :e :f :g :h :i :j)" " 1: (#primary-method<[:methodical.util.trace-test/x :default :default :default :default]>" " #primary-method<:default>" " :methodical.util.trace-test/x" @@ -98,10 +98,14 @@ " :c" " :d" " :e" - " :f)" - " 1> {:f :f, :x :methodical.util.trace-test/x}" - "0> {:f :f, :x :methodical.util.trace-test/x}"] - (trace-output lots-of-args-multifn ::x :b :c :d :e :f))))) + " :f" + " :g" + " :h" + " :i" + " :j)" + " 1> {:j :j, :x :methodical.util.trace-test/x}" + "0> {:j :j, :x :methodical.util.trace-test/x}"] + (trace-output lots-of-args-multifn ::x :b :c :d :e :f :g :h :i :j))))) (m/defmulti my= {:arglists '([x y])} diff --git a/test/methodical/util_test.clj b/test/methodical/util_test.clj index 95ee094..49033b2 100644 --- a/test/methodical/util_test.clj +++ b/test/methodical/util_test.clj @@ -5,6 +5,7 @@ [methodical.core :as m] [methodical.impl :as impl] [methodical.interface :as i] + [methodical.test-utils :as tu] [methodical.util :as u])) (t/deftest multifn?-test @@ -29,7 +30,7 @@ (t/testing "primary-method" (t/testing "primary-method should return primary methods with exactly the same dispatch value." (t/is (= 'm1 - (u/primary-method f CharSequence)))) + (tu/unwrap-fns-with-meta (u/primary-method f CharSequence))))) (t/testing "`primary-method` should not return default or parent primary methods -- just the exact match." (t/is (= nil (u/primary-method f String)))) @@ -41,7 +42,7 @@ (let [f (test-multifn)] (t/testing "applicable-primary-method should give you the primary method that will be used for a dispatch value." (t/is (= 'm1 - (u/applicable-primary-method f String))) + (tu/unwrap-fns-with-meta (u/applicable-primary-method f String)))) (t/testing "Should include dispatch value metadata" (t/is (= {:dispatch-value CharSequence} (meta (u/applicable-primary-method f String)))) @@ -120,7 +121,7 @@ (m/add-aux-method :before :default 'm4) (m/add-aux-method :before :default 'm5))] (t/is (= {:before ['m4 'm5]} - (u/default-aux-methods f'))))) + (tu/unwrap-fns-with-meta (u/default-aux-methods f')))))) (t/testing "default-effective-method" (t/is (= [:default] @@ -128,24 +129,24 @@ (def ^:private lots-of-args-multifn (-> (m/default-multifn - (fn [a b c d e _f] [a (class b) c d e])) + (fn [a b c d e _f _g _h _i _j] [a (class b) c d e])) (m/add-primary-method :default - (fn [_ a _ _ _ _ f] {:a a, :f f})) + (fn [_ a _ _ _ _ _ _ _ _ j] {:a a, :j j})) (m/add-primary-method [::x :default :default :default :default] - (fn [_ a _ _ _ _ f] {:x a, :f f})))) + (fn [_ a _ _ _ _ _ _ _ _ j] {:x a, :j j})))) (t/deftest lots-of-args-test - (t/is (= {:a :a, :f :f} - (lots-of-args-multifn :a :b :c :d :e :f))) - (t/is (= {:x ::x, :f :f} - (lots-of-args-multifn ::x :b :c :d :e :f)))) + (t/is (= {:a :a, :j :j} + (lots-of-args-multifn :a :b :c :d :e :f :g :h :i :j))) + (t/is (= {:x ::x, :j :j} + (lots-of-args-multifn ::x :b :c :d :e :f :g :h :i :j)))) (t/deftest dispatch-value-test (t/testing "dispatch-value should return the dispatch value of arg(s)" (let [f (m/default-multifn keyword)] (t/is (= :wow (u/dispatch-value f "wow")))) - (t/testing "2-4 args" + (t/testing "2-7 args" (let [f (-> (m/default-multifn vector) (m/add-primary-method :default (fn [& args] (vec args))))] (t/is (= [:a] @@ -155,10 +156,16 @@ (t/is (= [:a :b :c] (u/dispatch-value f :a :b :c))) (t/is (= [:a :b :c :d] - (u/dispatch-value f :a :b :c :d))))) - (t/testing "> 4 args" - (t/is [::x clojure.lang.Keyword :c :d :e] - (u/dispatch-value lots-of-args-multifn ::x :b :c :d :e :f))))) + (u/dispatch-value f :a :b :c :d))) + (t/is (= [:a :b :c :d :e] + (u/dispatch-value f :a :b :c :d :e))) + (t/is (= [:a :b :c :d :e :f] + (u/dispatch-value f :a :b :c :d :e :f))) + (t/is (= [:a :b :c :d :e :f :g] + (u/dispatch-value f :a :b :c :d :e :f :g))))) + (t/testing "> 7 args" + (t/is [::x clojure.lang.Keyword :c :d :e :f :g :h] + (u/dispatch-value lots-of-args-multifn ::x :b :c :d :e :f :g :h :i :j))))) (t/deftest effective-dispatch-value-test (doseq [default-method? [true false]] @@ -227,8 +234,8 @@ (m/effective-dispatch-value f [:default ::shoe]) (m/effective-dispatch-value f [nil ::shoe]))))) (t/testing "> 4 args" - (t/is [::x :default :default :default :default] - (->> (u/dispatch-value lots-of-args-multifn ::x :b :c :d :e :f) + (t/is [::x :default :default :default :default :default :default :default :default :default] + (->> (u/dispatch-value lots-of-args-multifn ::x :b :c :d :e :f :g :h :i :j) (u/effective-dispatch-value lots-of-args-multifn))))) (t/deftest dispatch-fn-test @@ -238,7 +245,7 @@ ((u/dispatch-fn f) "wow")))) (t/testing "> 4 args" (t/is [::x clojure.lang.Keyword :c :d :e] - ((u/dispatch-fn lots-of-args-multifn) ::x :b :c :d :e :f))))) + ((u/dispatch-fn lots-of-args-multifn) ::x :b :c :d :e :f :g :h :i :j))))) (t/deftest primary-methods-test (let [m1 (constantly [:char-sequence]) @@ -293,7 +300,7 @@ (t/testing "remove-all-aux-methods-for-dispatch-val" (t/is (= {:before {Object ['m2]} :after {Object ['m2 'm4]}} - (m/aux-methods (u/remove-all-aux-methods-for-dispatch-val f String))))) + (tu/unwrap-fns-with-meta (m/aux-methods (u/remove-all-aux-methods-for-dispatch-val f String)))))) ;; TODO (t/testing "remove-all-aux-methods!" @@ -310,7 +317,7 @@ :after {String ['m2 'm3] Object ['m2 'm4]} :around {String ['m1]}} - (m/aux-methods add-aux-method-multifn)))) + (tu/unwrap-fns-with-meta (m/aux-methods add-aux-method-multifn))))) (t/testing "remove-aux-method!" (def ^:private remove-aux-method-multifn f) @@ -319,13 +326,13 @@ Object ['m2]} :after {String ['m3] Object ['m2 'm4]}} - (m/aux-methods remove-aux-method-multifn))) + (tu/unwrap-fns-with-meta (m/aux-methods remove-aux-method-multifn)))) (u/remove-aux-method! #'remove-aux-method-multifn :before String 'm1) (t/is (= {:before {Object ['m2]} :after {String ['m3] Object ['m2 'm4]}} - (m/aux-methods remove-aux-method-multifn)) + (tu/unwrap-fns-with-meta (m/aux-methods remove-aux-method-multifn))) "Removing the last method for the dispatch value should remove that dispatch value entirely.")) (t/testing "remove-all-aux-methods-for-dispatch-val!" @@ -333,13 +340,13 @@ (u/remove-all-aux-methods-for-dispatch-val! #'remove-all-aux-methods-for-dispatch-val-multifn String) (t/is (= {:before {Object ['m2]} :after {Object ['m2 'm4]}} - (m/aux-methods remove-all-aux-methods-for-dispatch-val-multifn)))) + (tu/unwrap-fns-with-meta (m/aux-methods remove-all-aux-methods-for-dispatch-val-multifn))))) (t/testing "matching-aux-methods" (t/is (= {:before '[m1 m2] :after '[m2 m3 m2 m4]} - (u/matching-aux-methods f String) - (u/matching-aux-methods f f String)))))) + (tu/unwrap-fns-with-meta (u/matching-aux-methods f String)) + (tu/unwrap-fns-with-meta (u/matching-aux-methods f f String))))))) (t/deftest aux-methods-unique-key-test (t/testing "non-destructive operations")