Methodical0.0.1-SNAPSHOTFunctional and flexible multimethods for Clojure. Nondestructive multimethod construction, CLOS-style aux methods and method combinations, partial-default dispatch, easy next-method invocation, helpful debugging tools, and more. | (this space intentionally left almost blank) |
namespaces
| |
(ns methodical.profile
(:require [criterium.core :as criterium]
[methodical.core :as m]
[methodical.impl :as impl])) | |
(m/defmulti ^:private methodical-multifn :type) | |
(m/defmethod methodical-multifn :default [m] (assoc m :called :default)) | |
(m/defmethod methodical-multifn :amazing [m] (assoc m :called :amazing)) | |
(defmulti ^:private clojure-multimethod :type) | |
(defmethod clojure-multimethod :default [m] (assoc m :called :default)) | |
(defmethod clojure-multimethod :amazing [m] (assoc m :called :amazing)) | |
(defn- plain-fn-1 [m] (assoc m :called :amazing)) (defn- plain-fn-2 [m] (assoc m :called :default)) | |
(def ^:private m {:type :amazing})
(def ^:private m2 {:type :wow}) | |
(defn- profile []
(assert (= (methodical-multifn m) (clojure-multimethod m) (plain-fn-1 m)))
(assert (= (methodical-multifn m2) (clojure-multimethod m2) (plain-fn-2 m2)))
(println "\n\nProfiling plain fns...")
(criterium/bench
(do
(plain-fn-1 m)
(plain-fn-2 m2)))
(println "\n\nProfiling methodical...")
(criterium/bench
(do (methodical-multifn m)
(methodical-multifn m2)))
(println "\n\nProfiling vanilla clojure multimethod...")
(criterium/bench
(do
(clojure-multimethod m)
(clojure-multimethod m2)))) | |
(def ^:private big-hierarchy
(let [relationships
(for [child [:a :b :c :d :e :f]
parent [:g :h :i :j :k :l]
grandparent [:m :n :o :p :q :r]]
[child parent grandparent])]
(reduce
(fn [h [child parent grandparent]]
(-> h
(derive child parent)
(derive parent grandparent)))
(make-hierarchy)
relationships))) | |
(defmulti big-hierarchy-vanilla keyword :hierarchy #'big-hierarchy) | |
(prefer-method big-hierarchy-vanilla :o :p) | |
(defmethod big-hierarchy-vanilla :p [_] :p) | |
(m/defmulti big-hierarchy-methodical keyword :hierarchy #'big-hierarchy) | |
(m/defmethod big-hierarchy-methodical :p [_] :p) | |
(def big-hierarchy-methodical-clojure (impl/multifn (impl/clojure-multifn-impl keyword :hierarchy #'big-hierarchy))) | |
(m/defmethod big-hierarchy-methodical-clojure :p [_] :p) | |
(defn profile-big-hierarchy []
(assert
(= (big-hierarchy-vanilla :b)
(big-hierarchy-methodical :b)
(big-hierarchy-methodical-clojure :b)
:p))
(println "\n\nvanilla clojure")
(criterium/bench (big-hierarchy-vanilla :b))
(println "\n\nmethodical")
(criterium/bench (big-hierarchy-methodical :b))
(println "\n\nmethodical clojure")
(criterium/bench (big-hierarchy-methodical-clojure :b))) | |
(defn -main [] (println "(profile)") (profile) (println "(profile-big-hierarchy)") (profile-big-hierarchy)) | |
(ns user (:require [environ.core :as env] [humane-are.core :as humane-are] [pjstadig.humane-test-output :as humane-test-output])) | |
(when-not (get env/env :inhumane-test-output) (humane-test-output/activate!)) | |
(humane-are/install!) | |
Combined interface to everything in Methodical you'd normally want to use. | (ns methodical.core
(:refer-clojure :exclude [defmulti defmethod methods get-method remove-method
remove-all-methods prefer-method prefers])
(:require methodical.impl
methodical.interface
methodical.macros
methodical.util
methodical.util.describe
methodical.util.dispatch
methodical.util.trace
[potemkin :as p])) |
fool cljr-clean-ns and the namespace linter so it doesn't remove these automatically | (comment methodical.impl/keep-me methodical.interface/keep-me methodical.macros/keep-me methodical.util.describe/keep-me methodical.util.dispatch/keep-me methodical.util.trace/keep-me methodical.util/keep-me) |
(p/import-vars [methodical.macros defmulti defmethod] [methodical.interface ;; MethodCombination allowed-qualifiers combine-methods transform-fn-tail ;; MethodTable primary-methods add-primary-method remove-primary-method add-aux-method remove-aux-method ;; Dispatcher default-dispatch-value prefers with-prefers dominates? ;; MultiFnImpl method-combination dispatcher with-dispatcher method-table with-method-table effective-method] [methodical.impl ;; method combinations clojure-method-combination clos-method-combination thread-first-method-combination thread-last-method-combination do-method-combination min-method-combination max-method-combination +-method-combination seq-method-combination concat-method-combination and-method-combination or-method-combination ;; dispatchers standard-dispatcher everything-dispatcher multi-default-dispatcher ;; method tables clojure-method-table standard-method-table ;; caches simple-cache watching-cache ;; multifn impls standard-multifn-impl cached-multifn-impl default-multifn-impl clojure-multifn-impl clos-multifn-impl ;; multifn uncached-multifn multifn default-multifn] [methodical.util add-aux-method-with-unique-key applicable-primary-method aux-methods default-aux-methods default-effective-method default-primary-method dispatch-fn dispatch-value effective-dispatch-value effective-primary-method is-default-effective-method? is-default-primary-method? matching-aux-methods matching-primary-methods prefer-method primary-method remove-all-aux-methods remove-all-aux-methods-for-dispatch-val remove-all-methods remove-all-preferences remove-all-primary-methods remove-aux-method-with-unique-key unprefer-method ;; destructive ops add-aux-method! add-aux-method-with-unique-key! add-primary-method! prefer-method! remove-all-aux-methods! remove-all-aux-methods-for-dispatch-val! remove-all-methods! remove-all-preferences! remove-all-primary-methods! remove-aux-method! remove-aux-method-with-unique-key! remove-primary-method! unprefer-method! with-prefers!] [methodical.util.describe describe] [methodical.util.dispatch dispatch-on-first-arg dispatch-on-first-two-args dispatch-on-first-three-args dispatch-on-first-four-args] [methodical.util.trace trace]) | |
Convenience constructors for various implementations of the different component parts of a Methodical multifn. | (ns methodical.impl
(:refer-clojure :exclude [prefers])
(:require [methodical.impl.cache.simple :as cache.simple]
[methodical.impl.cache.watching :as cache.watching]
[methodical.impl.combo.clojure :as combo.clojure]
[methodical.impl.combo.clos :as combo.clos]
[methodical.impl.combo.operator :as combo.operator]
[methodical.impl.combo.threaded :as combo.threaded]
[methodical.impl.dispatcher.everything :as dispatcher.everything]
[methodical.impl.dispatcher.multi-default :as dispatcher.multi-default]
[methodical.impl.dispatcher.standard :as dispatcher.standard]
[methodical.impl.method-table.clojure :as method-table.clojure]
[methodical.impl.method-table.standard :as method-table.standard]
[methodical.impl.multifn.cached :as multifn.cached]
[methodical.impl.multifn.standard :as multifn.standard]
[methodical.impl.standard :as impl.standard]
methodical.interface)
(:import methodical.impl.standard.StandardMultiFn
[methodical.interface Cache Dispatcher MethodCombination MethodTable MultiFnImpl])) |
(comment methodical.interface/keep-me) | |
Method Combinations | |
Simple method combination strategy that mimics the way vanilla Clojure multimethods combine methods; that is, to say, not at all. Like vanilla Clojure multimethods, this method combination only supports primary methods. | (defn clojure-method-combination ^MethodCombination [] (combo.clojure/->ClojureMethodCombination)) |
Method combination strategy that mimics the standard method combination in the Common Lisp Object System (CLOS).
Supports | (defn clos-method-combination ^MethodCombination [] (combo.clos/->CLOSStandardMethodCombination)) |
Similar the the standard CLOS-style method combination, but threads the result of each | (defn thread-first-method-combination ^MethodCombination [] (combo.threaded/threading-method-combination :thread-first)) |
Similar the the standard CLOS-style method combination, but threads the result of each | (defn thread-last-method-combination ^MethodCombination [] (combo.threaded/threading-method-combination :thread-last)) |
CLOS-Inspired Operator Method Combinations | |
These combinations all work more or less the same way: they invoke all applicable primary methods, in order from most-specific to least specific, reducing the results using the function matching their name, e.g. (reduce + (method-1) (method-2) (method-3)) ; The following combinations all share the same constraints: they all support Because all of these combinations automatically invoke all relevant primary methods, like CLOS, their primary
methods do not get an implicit | |
Based on the CLOS | (defn do-method-combination ^MethodCombination [] (combo.operator/operator-method-combination :do)) |
Based on the CLOS method combination of the same name. Executes all applicable primary methods, returning the
minimum value returned by any implementation. Like | (defn min-method-combination ^MethodCombination [] (combo.operator/operator-method-combination :min)) |
Executes all applicable primary methods, and returns the maximum value returned by any one implementation. Same constraints as other CLOS operator-style method combinations. | (defn max-method-combination ^MethodCombination [] (combo.operator/operator-method-combination :max)) |
Executes all applicable primary methods, returnings the sum of the values returned by each method. Same constraints as other CLOS operator-style method combinations. | (defn +-method-combination ^MethodCombination [] (combo.operator/operator-method-combination :+)) |
Executes all applicable primary methods, from most-specific to least-specific; returns a sequence of results from
the method invocations. Inspired by CLOS | (defn seq-method-combination ^MethodCombination [] (combo.operator/operator-method-combination :seq)) |
Like the seq-method-combination : map :: concat-method-combination : mapcat | (defn concat-method-combination ^MethodCombination [] (combo.operator/operator-method-combination :concat)) |
Invoke all applicable primary methods, from most-specific to least-specific; reducing the results as if by | (defn and-method-combination ^MethodCombination [] (combo.operator/operator-method-combination :and)) |
Like the | (defn or-method-combination ^MethodCombination [] (combo.operator/operator-method-combination :or)) |
Dispatchers | |
Create a stanadrd Methodical multifn dispatcher. The standard dispatcher replicates the way vanilla Clojure
multimethods handle multimethod dispatch, with support for a custom | (defn standard-dispatcher
^Dispatcher [dispatch-fn & {:keys [hierarchy default-value prefers]
:or {hierarchy #'clojure.core/global-hierarchy
default-value :default
prefers {}}}]
{:pre [(ifn? dispatch-fn) (instance? clojure.lang.IDeref hierarchy) (map? prefers)]}
(dispatcher.standard/->StandardDispatcher dispatch-fn hierarchy default-value prefers)) |
A Dispatcher that always considers all primary and auxiliary methods to be matches; does not calculate dispatch
values for arguments when invoking. Dispatch values are still used to sort methods from most- to least- specific,
using | (defn everything-dispatcher
^Dispatcher [& {:keys [hierarchy prefers]
:or {hierarchy #'clojure.core/global-hierarchy
prefers {}}}]
{:pre [(instance? clojure.lang.IDeref hierarchy) (map? prefers)]}
(dispatcher.everything/->EverythingDispatcher hierarchy prefers)) |
Like the standard dispatcher, with one big improvement: when dispatching on multiple values, it supports default
methods that specialize on some args and use the default for others. (e.g. | (defn multi-default-dispatcher
^Dispatcher [dispatch-fn & {:keys [hierarchy default-value prefers]
:or {hierarchy #'clojure.core/global-hierarchy
default-value :default
prefers {}}}]
{:pre [(ifn? dispatch-fn) (instance? clojure.lang.IDeref hierarchy) (map? prefers)]}
(dispatcher.multi-default/->MultiDefaultDispatcher dispatch-fn hierarchy default-value prefers)) |
Method Tables | |
Create a new Clojure-style method table. Clojure-style method tables only support primary methods. | (defn clojure-method-table
(^MethodTable []
(clojure-method-table {}))
(^MethodTable [m]
{:pre [(map? m)]}
(method-table.clojure/->ClojureMethodTable m))) |
Create a new standard method table that supports both primary and auxiliary methods. | (defn standard-method-table
(^MethodTable []
(standard-method-table {} {}))
(^MethodTable [primary aux]
{:pre [(map? primary) (map? aux)]}
(method-table.standard/->StandardMethodTable primary aux))) |
Caches | |
Create a basic dumb cache. The simple cache stores | (defn simple-cache
(^Cache []
(simple-cache {}))
(^Cache [m]
(cache.simple/->SimpleCache (atom m)))) |
Wrap | (defn watching-cache ^Cache [cache references] (cache.watching/add-watches cache references)) |
MultiFn Impls | |
Create a basic multifn impl using method combination | (defn standard-multifn-impl
^MultiFnImpl [combo dispatcher method-table]
{:pre [(instance? MethodCombination combo)
(instance? Dispatcher dispatcher)
(instance? MethodTable method-table)]}
(multifn.standard/->StandardMultiFnImpl combo dispatcher method-table)) |
Create a basic multifn impl using default choices for method combination, dispatcher, and method table. | (defn default-multifn-impl
{:arglists '([dispatch-fn & {:keys [hierarchy default-value prefers]}])}
^MultiFnImpl [dispatch-fn & dispatcher-options]
(standard-multifn-impl
(thread-last-method-combination)
(apply multi-default-dispatcher dispatch-fn dispatcher-options)
(standard-method-table))) |
Create a mulitfn impl that largely behaves the same way as a vanilla Clojure multimethod. | (defn clojure-multifn-impl
{:arglists '([dispatch-fn & {:keys [hierarchy default-value prefers method-table]}])}
^MultiFnImpl [dispatch-fn & {:keys [method-table], :or {method-table {}}, :as options}]
(let [dispatcher-options (apply concat (select-keys options [:hierarchy :default-value :prefers]))]
(standard-multifn-impl
(clojure-method-combination)
(apply standard-dispatcher dispatch-fn dispatcher-options)
(clojure-method-table method-table)))) |
Convenience for creating a new multifn instances that for the most part mimics the behavior of CLOS generic functions
using the standard method combination. Supports | (defn clos-multifn-impl
{:arglists '([dispatch-fn & {:keys [hierarchy default-value prefers primary-method-table aux-method-table]}])}
^MultiFnImpl [dispatch-fn & {:keys [primary-method-table aux-method-table],
:or {primary-method-table {}, aux-method-table {}}
:as options}]
(let [dispatcher-options (apply concat (select-keys options [:hierarchy :default-value :prefers]))]
(standard-multifn-impl
(clos-method-combination)
(apply standard-dispatcher dispatch-fn dispatcher-options)
(standard-method-table primary-method-table aux-method-table)))) |
Wrap a | (defn cached-multifn-impl (^MultiFnImpl [impl] (cached-multifn-impl impl (simple-cache))) (^MultiFnImpl [impl cache] (multifn.cached/->CachedMultiFnImpl impl cache))) |
Standard MultiFn | |
Create a new Methodical multifn using | (defn uncached-multifn (^StandardMultiFn [impl] (uncached-multifn impl nil)) (^StandardMultiFn [impl mta] (impl.standard/->StandardMultiFn impl mta))) |
Create a new cached Methodical multifn using | (defn multifn (^StandardMultiFn [impl] (multifn impl nil)) (^StandardMultiFn [impl mta] (multifn impl mta (simple-cache))) (^StandardMultiFn [impl mta cache] (uncached-multifn (cached-multifn-impl impl cache) mta))) |
Create a new Methodical multifn using the default impl. | (def ^{:arglists (:arglists (meta #'default-multifn-impl))}
default-multifn
(comp multifn default-multifn-impl)) |
A basic, dumb cache. | (ns methodical.impl.cache.simple (:require [clojure.core.protocols :as clojure.protocols] [methodical.interface] [methodical.util.describe :as describe] [pretty.core :as pretty]) (:import (methodical.interface Cache))) |
(set! *warn-on-reflection* true) | |
(comment methodical.interface/keep-me) | |
(deftype SimpleCache [atomm]
pretty/PrettyPrintable
(pretty [_]
'(simple-cache))
Cache
(cached-method [_ dispatch-value]
(get @atomm dispatch-value))
(cache-method! [_ dispatch-value method]
(swap! atomm assoc dispatch-value method))
(clear-cache! [this]
(reset! atomm {})
this)
(empty-copy [_]
(SimpleCache. (atom {})))
clojure.protocols/Datafiable
(datafy [this]
{:class (class this)
:cache @atomm})
describe/Describable
(describe [this]
(format "It caches methods using a `%s`." (.getCanonicalName (class this))))) | |
A [[methodical.interface/Cache]] implementation that wraps any other cache, watching one or more references (such as an atom or var), calling [[methodical.interface/clear-cache!]] whenever one of those references changes.
| (ns methodical.impl.cache.watching (:require [clojure.core.protocols :as clojure.protocols] [clojure.datafy :as datafy] [methodical.interface :as i] [methodical.util.describe :as describe] [pretty.core :as pretty]) (:import (java.lang.ref WeakReference) (methodical.interface Cache))) |
(set! *warn-on-reflection* true) | |
(declare add-watches remove-watches) | |
(deftype WatchingCache [^Cache cache watch-key refs]
pretty/PrettyPrintable
(pretty [_]
(concat ['watching-cache cache 'watching] refs))
Object
(finalize [this]
(remove-watches this))
Cache
(cached-method [_ dispatch-value]
(.cached-method cache dispatch-value))
(cache-method! [this dispatch-value method]
(.cache-method! cache dispatch-value method)
this)
(clear-cache! [this]
(.clear-cache! cache)
this)
(empty-copy [_]
(add-watches (i/empty-copy cache) refs))
clojure.protocols/Datafiable
(datafy [this]
{:class (class this)
:cache (datafy/datafy cache)
:refs refs})
describe/Describable
(describe [this]
(format "It caches methods using a `%s`." (.getCanonicalName (class this))))) | |
(defn- cache-watch-fn [cache]
(let [cache-weak-ref (WeakReference. cache)]
(fn [_ _ old-value new-value]
(when-let [cache (.get cache-weak-ref)]
(when-not (= old-value new-value)
(i/clear-cache! cache)))))) | |
(defn- new-cache-with-watches
^WatchingCache [^Cache wrapped-cache watch-key refs]
(let [cache (WatchingCache. wrapped-cache watch-key (set refs))
watch-fn (cache-watch-fn cache)]
(doseq [reference refs]
(add-watch reference watch-key watch-fn))
cache)) | |
Create a new cache that watches
| (defn add-watches
^Cache [^Cache cache refs]
{:pre [(every? (partial instance? clojure.lang.IRef) refs)]}
(cond
(empty? refs)
cache
(and (instance? WatchingCache cache)
(= (set refs) (set (.refs ^WatchingCache cache))))
cache
(instance? WatchingCache cache)
(let [^WatchingCache cache cache]
(recur (.cache cache) (into (set (.refs cache)) refs)))
:else
(new-cache-with-watches cache (gensym "watching-cache-") refs))) |
Recursively removes all watches from | (defn remove-watches
[cache]
(if-not (instance? WatchingCache cache)
cache
(let [^WatchingCache cache cache
watch-key (.watch-key cache)]
(doseq [reference (.refs cache)]
(remove-watch reference watch-key))
(recur (.cache cache))))) |
Simple method combination strategy that mimics the way vanilla Clojure multimethods combine methods; that is, to say, not at all. Like vanilla Clojure multimethods, this method combination only supports primary methods. | (ns methodical.impl.combo.clojure (:require [clojure.core.protocols :as clojure.protocols] [methodical.interface] [methodical.util.describe :as describe] [pretty.core :as pretty]) (:import (methodical.interface MethodCombination))) |
(set! *warn-on-reflection* true) | |
(comment methodical.interface/keep-me) | |
(deftype ClojureMethodCombination []
pretty/PrettyPrintable
(pretty [_]
'(clojure-method-combination))
Object
(equals [_ another]
(instance? ClojureMethodCombination another))
MethodCombination
(allowed-qualifiers [_]
#{nil}) ; only primary methods
(combine-methods [_ [primary-method] aux-methods]
(when (seq aux-methods)
(throw (UnsupportedOperationException. "Clojure-style multimethods do not support auxiliary methods.")))
primary-method)
(transform-fn-tail [_this _qualifier fn-tail]
fn-tail)
clojure.protocols/Datafiable
(datafy [this]
{:class (class this)})
describe/Describable
(describe [this]
(format "It uses the method combination `%s`." (.getCanonicalName (class this))))) | |
Method combination strategy that mimics the standard method combination in the Common Lisp Object System (CLOS).
Supports | (ns methodical.impl.combo.clos (:require [clojure.core.protocols :as clojure.protocols] [methodical.impl.combo.common :as combo.common] [methodical.interface] [methodical.util.describe :as describe] [pretty.core :as pretty]) (:import (methodical.interface MethodCombination))) |
(set! *warn-on-reflection* true) | |
(comment methodical.interface/keep-me) | |
TODO - I'm 90% sure we can leverage the | (defn- apply-befores [combined-method befores]
(if (empty? befores)
combined-method
(fn
([]
(doseq [before befores]
(before))
(combined-method))
([a]
(doseq [before befores]
(before a))
(combined-method a))
([a b]
(doseq [before befores]
(before a b))
(combined-method a b))
([a b c]
(doseq [before befores]
(before a b c))
(combined-method a b c))
([a b c d]
(doseq [before befores]
(before a b c d))
(combined-method a b c d))
([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)
combined-method
(let [afters (reverse afters)
apply-after-fns (fn [result]
(doseq [f afters]
(f result))
result)]
(comp apply-after-fns combined-method)))) | |
(deftype CLOSStandardMethodCombination []
pretty/PrettyPrintable
(pretty [_]
'(clos-method-combination))
Object
(equals [_ another]
(instance? CLOSStandardMethodCombination another))
MethodCombination
(allowed-qualifiers [_]
#{nil :before :after :around})
(combine-methods [_ primary-methods {:keys [before after around]}]
(some-> (combo.common/combine-primary-methods primary-methods)
(apply-befores before)
(apply-afters after)
(combo.common/apply-around-methods around)))
(transform-fn-tail [_ qualifier fn-tail]
(combo.common/add-implicit-next-method-args qualifier fn-tail))
clojure.protocols/Datafiable
(datafy [this]
{:class (class this)})
describe/Describable
(describe [this]
(format "It uses the method combination `%s`." (.getCanonicalName (class this))))) | |
Utility functions for implementing method combinations. | (ns methodical.impl.combo.common (:require [methodical.util :as u])) |
[[clojure.core/partial]] but with more direct arities. | (defn partial*
([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))))) |
Combine all | (defn combine-primary-methods
[primary-methods]
(when (seq primary-methods)
(reduce
(fn [next-method primary-method]
(u/fn-with-meta (partial* (u/unwrap-fn-with-meta primary-method) next-method)
(meta primary-method)))
nil
(reverse primary-methods)))) |
Combine | (defn apply-around-methods
[combined-method around-methods]
(reduce
(fn [combined-method around-method]
(u/fn-with-meta (partial* (u/unwrap-fn-with-meta around-method) combined-method)
(meta around-method)))
combined-method
around-methods)) |
Helpers for implementing `transform-fn-tail` | |
Transform | (defn transform-fn-tail
[f fn-tail]
{:pre [(sequential? fn-tail)]}
(cond
(vector? (first fn-tail))
(apply f fn-tail)
(vector? (ffirst 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)+)"
(pr-str fn-tail))
{:f f, :fn-tail fn-tail})))) |
Add an implicit | (defn add-implicit-arg
[arg fn-tail]
(transform-fn-tail
(fn [bindings & body]
(cons (into [arg] bindings) body))
fn-tail)) |
Add an implicit | (defn add-implicit-next-method-args
[qualifier fn-tail]
(case qualifier
nil (add-implicit-arg 'next-method fn-tail)
:before fn-tail
:after fn-tail
:around (add-implicit-arg 'next-method fn-tail))) |
Method combinations strategies based on the non-default method combination types in CLOS. All non-default method combinations follow the same basic pattern: ```clj (operator (primary-method-1 args) (primary-method-2 args) (primary-method-3 args))) ``` (Example from "Object-Oriented Programming in Common Lisp", Keene 1988.) The non-default method combinations each support primary methods and There are 9 built-in method combinations types in CLOS, excluding
One last difference: unlike CLOS operator method combinations, primary method implementations are not qualified by their operator. ```clj ;; CLOS (defmethod total-electric-supply + ((city city)) ...) ;; Methodical (defmethod total-electric-supply :city [city] ...) ``` | (ns methodical.impl.combo.operator (:refer-clojure :exclude [methods]) (:require [clojure.core.protocols :as clojure.protocols] [clojure.core.specs.alpha] [clojure.spec.alpha :as s] [methodical.impl.combo.common :as combo.common] [methodical.interface] [methodical.util.describe :as describe] [pretty.core :as pretty]) (:import (methodical.interface MethodCombination))) |
(set! *warn-on-reflection* true) | |
(comment clojure.core.specs.alpha/keep-me ; for the specs
methodical.interface/keep-me) | |
Define a new operator that can be used as part of an | (defmulti operator
{:arglists '([operator-name])}
keyword) |
(defn- invoke-fn ([] (fn [method] (method))) ([a] (fn [method] (method a))) ([a b] (fn [method] (method a b))) ([a b c] (fn [method] (method a b c))) ([a b c d] (fn [method] (method a b c d))) ([a b c d & more] (fn [method] (apply method a b c d more)))) | |
(defn- reducing-operator [reducer] (comp reducer invoke-fn)) | |
Part of the impl for [[defoperator]]. | (defn ^:no-doc combine-methods-with-operator
[f]
(fn combine*
([primary-methods]
(when (seq primary-methods)
(reducing-operator (f primary-methods))))
([primary-methods {:keys [around]}]
(combo.common/apply-around-methods (combine* primary-methods) around)))) |
Define a new operator that can be used as part of an | (defmacro defoperator
[operator-name [methods-binding invoke-binding] & body]
`(let [fn# (combine-methods-with-operator
(fn [~methods-binding]
(fn [~invoke-binding]
~@body)))]
(defmethod operator ~(keyword operator-name)
[~'_]
fn#))) |
(s/fdef defoperator
:args (s/cat :operator-name keyword?
:bindings (s/spec (s/cat :methods :clojure.core.specs.alpha/binding-form
:invoke symbol?))
:body (s/+ any?))
:ret any?) | |
Predefined operators | |
(defoperator :do [methods invoke]
(loop [[method & more] methods]
(let [result (invoke method)]
(if (seq more)
(recur more)
result)))) | |
(defoperator :seq [methods invoke]
((fn seq* [[method & more]]
(lazy-seq
(cons
(invoke method)
(when (seq more)
(seq* more)))))
methods)) | |
(defoperator :concat [methods invoke]
((fn seq* [[method & more]]
(lazy-seq
(concat
(invoke method)
(when (seq more)
(seq* more)))))
methods)) | |
(defoperator :and [methods invoke]
(loop [[method & more] methods]
(let [result (invoke method)]
(if (and result (seq more))
(recur more)
result)))) | |
(defoperator :or [methods invoke]
(loop [[method & more] methods]
(or (invoke method)
(when (seq more)
(recur more))))) | |
(defoperator :max [methods invoke]
(loop [current-max nil, [method & more] methods]
(let [result (invoke method)
new-max (if current-max
(max result current-max)
result)]
(if (seq more)
(recur new-max more)
new-max)))) | |
(defoperator :min [methods invoke]
(loop [current-min nil, [method & more] methods]
(let [result (invoke method)
new-min (if current-min
(min result current-min)
result)]
(if (seq more)
(recur new-min more)
new-min)))) | |
(defoperator :+ [methods invoke]
(loop [sum 0, [method & more] methods]
(let [sum (+ (long (invoke method)) sum)]
(if (seq more)
(recur sum more)
sum)))) | |
`OperatorMethodCombination` | |
(deftype OperatorMethodCombination [operator-name]
pretty/PrettyPrintable
(pretty [_]
(list 'operator-method-combination operator-name))
Object
(equals [_ another]
(and (instance? OperatorMethodCombination another)
(= operator-name (.operator-name ^OperatorMethodCombination another))))
MethodCombination
(allowed-qualifiers [_]
#{nil :around})
(combine-methods [_ primary-methods {:keys [around]}]
(when (seq primary-methods)
(combo.common/apply-around-methods ((operator operator-name) primary-methods)
around)))
(transform-fn-tail [_ qualifier fn-tail]
(if (= qualifier :around)
(combo.common/add-implicit-next-method-args qualifier fn-tail)
fn-tail))
clojure.protocols/Datafiable
(datafy [this]
{:class (class this)
:operator operator-name})
describe/Describable
(describe [this]
(format "It uses the method combination `%s`\nwith the operator `%s`."
(.getCanonicalName (class this))
(pr-str operator-name)))) | |
Create a new method combination using the operator named by (operator-method-combination :max) | (defn operator-method-combination
[operator-name]
(assert (operator operator-name)
(format "Invalid operator method combination: %s" operator-name))
(OperatorMethodCombination. (keyword operator-name))) |
(ns methodical.impl.combo.threaded (:refer-clojure :exclude [methods]) (:require [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 (methodical.interface MethodCombination))) | |
(set! *warn-on-reflection* true) | |
(comment methodical.interface/keep-me) | |
Combine primary and auxiliary methods using a thread-first threading type. | (defn combine-methods-thread-first
[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))) |
Combine primary and auxiliary methods using a thread-last threading type. | (defn combine-methods-thread-last
[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
(pretty [_]
(list 'threading-method-combination threading-type))
MethodCombination
Object
(equals [_ another]
(and (instance? ThreadingMethodCombination another)
(= threading-type (.threading-type ^ThreadingMethodCombination another))))
MethodCombination
(allowed-qualifiers [_]
#{nil :before :after :around})
(combine-methods [_ 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))
clojure.protocols/Datafiable
(datafy [this]
{:class (class this)
:threading-type threading-type})
describe/Describable
(describe [this]
(format "It uses the method combination `%s`\nwith the threading strategy `%s`."
(.getCanonicalName (class this))
(pr-str threading-type)))) | |
Create a new | (defn threading-method-combination
[threading-type]
{:pre [(#{:thread-first :thread-last} threading-type)]}
(ThreadingMethodCombination. threading-type)) |
Utility functions for implementing Dispatchers. | (ns methodical.impl.dispatcher.common) |
True if | (defn prefers?
[hierarchy prefs x y]
(or
;; direct preference for x over y
(contains? (get prefs x) y)
;; direct preference for x over one of y's parents (or ancestors, recursively)
(some
#(prefers? hierarchy prefs x %)
(parents hierarchy y))
;; direct preference for one of x's parents (or ancestors, recursively) over y
(some
#(prefers? hierarchy prefs % y)
(parents hierarchy x)))) |
True if dispatch value 4-arity version does not take the | (defn dominates?
([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))))) |
Given a | (defn domination-comparator
([dominates?-pred]
(fn [x y]
(cond
(= x y) 0
(dominates?-pred x y) -1
(dominates?-pred y x) 1
:else 0)))
([hierarchy prefs]
(domination-comparator (partial dominates? hierarchy prefs)))
([hierarchy prefs dispatch-value]
(let [f (domination-comparator hierarchy prefs)]
(fn [x y]
(condp = dispatch-value
x -2
y 2
(f x y)))))) |
True if neither | (defn ambiguous? [hierarchy prefs dispatch-value dispatch-val-x dispatch-val-y] (zero? ((domination-comparator hierarchy prefs dispatch-value) dispatch-val-x dispatch-val-y))) |
Like | (defn distinct-by
([f]
(fn [rf]
(let [seen (volatile! #{})]
(fn
([] (rf))
([result] (rf result))
([result input]
(let [v (f input)]
(if (contains? @seen v)
result
(do (vswap! seen conj v)
(rf result input)))))))))
([f coll]
(into [] (distinct-by f) coll))) |
(ns methodical.impl.dispatcher.everything (:refer-clojure :exclude [methods]) (:require [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 (methodical.interface Dispatcher))) | |
(set! *warn-on-reflection* true) | |
(deftype EverythingDispatcher [hierarchy-var prefs]
pretty/PrettyPrintable
(pretty [_]
(cons
'everything-dispatcher
(concat
(when (not= hierarchy-var #'clojure.core/global-hierarchy)
[:hierarchy hierarchy-var])
(when (seq prefs)
[:prefers prefs]))))
Object
(equals [_ another]
(and
(instance? EverythingDispatcher another)
(let [^EverythingDispatcher another another]
(and
(= hierarchy-var (.hierarchy-var another))
(= 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 _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)]
(u/fn-vary-meta method assoc :dispatch-value dispatch-value))))
(matching-aux-methods [_ method-table _]
(let [aux-methods (i/aux-methods method-table)
comparatorr (dispatcher.common/domination-comparator (deref hierarchy-var) prefs)]
(into {} (for [[qualifier dispatch-value->methods] aux-methods]
[qualifier (for [[dispatch-value methods] (sort-by first comparatorr dispatch-value->methods)
method methods]
(u/fn-vary-meta method assoc :dispatch-value dispatch-value))]))))
(default-dispatch-value [_]
nil)
(prefers [_]
prefs)
(with-prefers [_this new-prefs]
(EverythingDispatcher. hierarchy-var new-prefs))
(dominates? [_ x y]
(dispatcher.common/dominates? (deref hierarchy-var) prefs x y))
clojure.protocols/Datafiable
(datafy [this]
{:class (class this)
:hierarchy hierarchy-var
:prefs prefs})
describe/Describable
(describe [this]
(format "It uses the dispatcher `%s`\nwith hierarchy `%s`\nand prefs `%s`."
(.getCanonicalName (class this))
(pr-str hierarchy-var)
(pr-str prefs)))) | |
A single-hierarchy dispatcher similar to the standard dispatcher, with one big improvement: when dispatching on
multiple values, it supports default methods that specialize on some args and use the default for others. (e.g.
| (ns methodical.impl.dispatcher.multi-default (:require [clojure.core.protocols :as clojure.protocols] [methodical.impl.dispatcher.common :as dispatcher.common] [methodical.impl.dispatcher.standard :as dispatcher.standard] [methodical.interface :as i] [methodical.util.describe :as describe] [pretty.core :as pretty]) (:import (methodical.interface Dispatcher))) |
(set! *warn-on-reflection* true) | |
(defn- partially-specialized-default-dispatch-values* [dispatch-value default-value]
;; The basic idea here is to count down from (2^(count dispatch-value) - 2) to 0, then treat each bit as whether the
;; value at the corresponding position in `dispatch-value` should be included (if the bit is `1`) or if
;; `default-value` should be included in its place (if the bit is `0`). e.g. for
;;
;; (partially-specialized-default-dispatch-values [:x :y] :default)
;;
;; then
;;
;; (count dispatch-value)` is 2
;; 2^count = 4
;;
;; i.e., count from 2 down to 0. The table below illustrates how this works:
;;
;; i | binary | corresponding dispatch val
;; --+--------+---------------------------
;; 2 | 10 | [:x :default]
;; 1 | 01 | [:default :y]
;; 0 | 00 | [:default :default]
(let [cnt (count dispatch-value)]
(mapv (fn [i]
(mapv (fn [j]
(if (pos? (bit-and i (bit-shift-left 1 j)))
(nth dispatch-value (- cnt j 1))
default-value))
(range (dec cnt) -1 -1)))
(range (- (int (Math/pow 2 cnt)) 2) -1 -1)))) | |
Return a sequence of all partially-specialized default dispatch values for a given ```clj (default-dispatch-values [:x :y] :default) -> ([:x :default] ; if no method for [:x :y] exists, look for [:x :default]... [:default :y] ; or [:default :y] ... [:default :default]) ``` | (defn partially-specialized-default-dispatch-values
[dispatch-value default-value]
(when (and (sequential? dispatch-value)
(not (sequential? default-value)))
(partially-specialized-default-dispatch-values* dispatch-value default-value))) |
Return pairs of | (defn matching-partially-specialized-default-primary-method-pairs
;; TODO - this is too many args!
[opts standard-dispatch-vals]
(let [{:keys [default-value dispatch-value unambiguous-pairs-seq-fn]
:or {unambiguous-pairs-seq-fn dispatcher.standard/unambiguous-pairs-seq}} opts]
(into []
(comp (mapcat (fn [partial-default]
(let [pairs (dispatcher.standard/matching-primary-pairs-excluding-default
(assoc opts :dispatch-value partial-default))]
(unambiguous-pairs-seq-fn opts pairs))))
(dispatcher.common/distinct-by first)
(remove (fn [[dispatch-val]] (contains? standard-dispatch-vals dispatch-val))))
(partially-specialized-default-dispatch-values dispatch-value default-value)))) |
Return a lazy sequence of applicable priamry methods for | (defn matching-primary-methods
[{:keys [default-value method-table unambiguous-pairs-seq-fn]
:or {unambiguous-pairs-seq-fn dispatcher.standard/unambiguous-pairs-seq}
:as opts}]
{:pre [(some? method-table)]}
;; this is basically the same logic as the version in `standard`, but instead `matches + default` we return
;; `matches + partial-defaults + default`
(let [primary-methods (i/primary-methods method-table)
opts (assoc opts :method-map primary-methods)
standard-pairs (dispatcher.standard/matching-primary-pairs-excluding-default opts)
;; filter out any partially-specialized default methods that already appear in the standard matches, e.g. if
;; dispatch value is something like [:x :default]
standard-dispatch-vals (set (map first standard-pairs))
partial-default-pairs (matching-partially-specialized-default-primary-method-pairs opts standard-dispatch-vals)
default-pair (when-not (or (contains? standard-dispatch-vals default-value)
(contains? (set (map first partial-default-pairs)) default-value))
(when-let [default-method (get primary-methods default-value)]
[default-value default-method]))
pairs (concat
(unambiguous-pairs-seq-fn opts standard-pairs)
partial-default-pairs
(when default-pair [default-pair]))]
(map second (dispatcher.common/distinct-by first pairs)))) |
(defn- aux-dispatch-values [qualifier {:keys [default-value method-table dispatch-value hierarchy prefs]}]
(let [comparatorr (dispatcher.common/domination-comparator hierarchy prefs dispatch-value)]
(distinct
(sort-by
identity
comparatorr
(for [dispatch-value (concat [dispatch-value]
(partially-specialized-default-dispatch-values dispatch-value default-value)
[default-value])
dv (keys (get (i/aux-methods method-table) qualifier))
:when (isa? hierarchy dispatch-value dv)]
dv))))) | |
(defn- matching-aux-methods*
[qualifier {:keys [method-table] :as opts}]
(let [method-map (i/aux-methods method-table)]
(for [dispatch-value (aux-dispatch-values qualifier opts)
m (get-in method-map [qualifier dispatch-value])]
m))) | |
Impl of | (defn matching-aux-methods
[{:keys [method-table] :as opts}]
(into {} (for [[qualifier] (i/aux-methods method-table)]
[qualifier (matching-aux-methods* qualifier opts)]))) |
(deftype MultiDefaultDispatcher [dispatch-fn hierarchy-var default-value prefs]
pretty/PrettyPrintable
(pretty [_]
(concat ['multi-default-dispatcher dispatch-fn]
(when (not= hierarchy-var #'clojure.core/global-hierarchy)
[:hierarchy hierarchy-var])
(when (not= default-value :default)
[:default-value default-value])
(when (seq prefs)
[:prefers prefs])))
Object
(equals [_ another]
(and
(instance? MultiDefaultDispatcher another)
(let [^MultiDefaultDispatcher another another]
(and
(= dispatch-fn (.dispatch-fn another))
(= hierarchy-var (.hierarchy-var another))
(= default-value (.default-value another))
(= 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 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
{:hierarchy (deref hierarchy-var)
:prefs prefs
:default-value default-value
:method-table method-table
:dispatch-value dispatch-value}))
(matching-aux-methods [_ method-table dispatch-value]
(matching-aux-methods
{:hierarchy (deref hierarchy-var)
:prefs prefs
:default-value default-value
:method-table method-table
:dispatch-value dispatch-value}))
(default-dispatch-value [_]
default-value)
(prefers [_]
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))
clojure.protocols/Datafiable
(datafy [this]
{:class (class this)
:dispatch-fn dispatch-fn
:default-value default-value
:hierarchy hierarchy-var
:prefs prefs})
describe/Describable
(describe [this]
(format "It uses the dispatcher `%s`\nwith hierarchy `%s`\nand prefs `%s`.\n\nThe default value is `%s`."
(.getCanonicalName (class this))
(pr-str hierarchy-var)
(pr-str prefs)
(pr-str default-value)))) | |
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. | (ns methodical.impl.dispatcher.standard (:refer-clojure :exclude [prefers methods]) (:require [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 (methodical.interface Dispatcher))) |
(set! *warn-on-reflection* true) | |
Return a sequence of pairs of | (defn matching-primary-pairs-excluding-default
[{:keys [hierarchy prefs method-map dispatch-value]}]
{:pre [(map? method-map)]}
(let [matches (for [[a-dispatch-val method] method-map
:when (isa? hierarchy dispatch-value a-dispatch-val)]
[a-dispatch-val method])]
(when (seq matches)
(sort-by first (dispatcher.common/domination-comparator hierarchy prefs dispatch-value) matches)))) |
(defn- ambiguous-error-fn [dispatch-val method-1 dispatch-val-1 method-2 dispatch-val-2]
(fn [& _]
(let [multimethod-name (or (some-> (:multifn (meta method-1)) symbol)
(some-> (:multifn (meta method-2)) symbol)
;; if we don't have the multimethod name for whatever reason then just use 'Multimethod'
;; as a placeholder. The error message will still make sense.
"Multimethod")]
(throw
(ex-info (format "%s: multiple methods match dispatch value: %s -> %s and %s, and neither is preferred."
multimethod-name dispatch-val dispatch-val-1 dispatch-val-2)
{:method-1 (assoc (select-keys (meta method-1) [:ns :file :line])
:dispatch-value dispatch-val-1)
:method-2 (assoc (select-keys (meta method-2) [:ns :file :line])
:dispatch-value dispatch-val-2)}))))) | |
Given a sequence of | (defn unambiguous-pairs-seq
[{:keys [hierarchy prefs dispatch-value ambiguous-fn]
:or {ambiguous-fn dispatcher.common/ambiguous?}
:as opts}
[[this-dispatch-val this-method :as _this-pair]
[next-dispatch-val next-method :as next-pair]
& more-pairs :as pairs]]
{:pre [(every? sequential? pairs)]}
(when (seq pairs)
(let [this-pair [this-dispatch-val
(if (and next-pair
(ambiguous-fn hierarchy prefs dispatch-value this-dispatch-val next-dispatch-val))
(ambiguous-error-fn dispatch-value this-method this-dispatch-val next-method next-dispatch-val)
this-method)]]
(cons this-pair (when next-pair
(unambiguous-pairs-seq opts (cons next-pair more-pairs))))))) |
Return a lazy sequence of applicable primary methods for | (defn matching-primary-methods
{:arglists '([{:keys [hierarchy prefs default-value method-table dispatch-value]}])}
[{:keys [hierarchy default-value method-table dispatch-value], :as opts}]
{:pre [(map? hierarchy) (some? method-table)]}
(let [opts (assoc opts :method-map (i/primary-methods method-table))
pairs (unambiguous-pairs-seq opts (matching-primary-pairs-excluding-default opts))
default-method (when (not= dispatch-value default-value)
(get (i/primary-methods method-table) default-value))]
(concat
(for [[dispatch-value method] pairs]
(u/fn-vary-meta method assoc :dispatch-value dispatch-value))
(when (and default-method
(not (contains? (set (map first pairs)) default-value)))
[(u/fn-vary-meta default-method assoc :dispatch-value default-value)])))) |
Return pairs of | (defn- matching-aux-pairs-excluding-default
[qualifier {:keys [hierarchy prefs method-table dispatch-value]}]
{:pre [(map? hierarchy)]}
(let [pairs (for [[dv methods] (get (i/aux-methods method-table) qualifier)
:when (isa? hierarchy dispatch-value dv)
method methods]
[dv method])]
(sort-by first (dispatcher.common/domination-comparator hierarchy prefs dispatch-value) pairs))) |
Return pairs of | (defn matching-aux-pairs
[qualifier {:keys [default-value method-table dispatch-value], :as opts}]
(let [pairs (matching-aux-pairs-excluding-default qualifier opts)
default-methods (when-not (contains? (set (map first pairs)) dispatch-value)
(get-in (i/aux-methods method-table) [qualifier default-value]))
default-pairs (for [method default-methods]
[default-value method])]
(concat pairs default-pairs))) |
Return a map of aux method qualifier -> sequence of applicable methods for | (defn matching-aux-methods
[{:keys [method-table] :as opts}]
(into {} (for [[qualifier] (i/aux-methods method-table)
:let [pairs (matching-aux-pairs qualifier opts)]
:when (seq pairs)]
[qualifier (for [[dispatch-value method] pairs]
(u/fn-vary-meta method assoc :dispatch-value dispatch-value))]))) |
(deftype StandardDispatcher [dispatch-fn hierarchy-var default-value prefs]
pretty/PrettyPrintable
(pretty [_]
(concat ['standard-dispatcher dispatch-fn]
(when (not= hierarchy-var #'clojure.core/global-hierarchy)
[:hierarchy hierarchy-var])
(when (not= default-value :default)
[:default-value default-value])
(when (seq prefs)
[:prefers prefs])))
Object
(equals [_ another]
(and
(instance? StandardDispatcher another)
(let [^StandardDispatcher another another]
(and
(= dispatch-fn (.dispatch-fn another))
(= hierarchy-var (.hierarchy-var another))
(= default-value (.default-value another))
(= 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 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
{:hierarchy (deref hierarchy-var)
:prefs prefs
:default-value default-value
:method-table method-table
:dispatch-value dispatch-value}))
(matching-aux-methods [_ method-table dispatch-value]
(matching-aux-methods
{:hierarchy (deref hierarchy-var)
:prefs prefs
:default-value default-value
:method-table method-table
:dispatch-value dispatch-value}))
(default-dispatch-value [_]
default-value)
(prefers [_]
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))
clojure.protocols/Datafiable
(datafy [this]
{:class (class this)
:dispatch-fn dispatch-fn
:default-value default-value
:hierarchy hierarchy-var
:prefs prefs})
describe/Describable
(describe [this]
(format "It uses the dispatcher `%s`\nwith hierarchy `%s`\nand prefs `%s`.\n\nThe default value is `%s`."
(.getCanonicalName (class this))
(pr-str hierarchy-var)
(pr-str prefs)
(pr-str default-value)))) | |
(ns methodical.impl.method-table.clojure (:require [clojure.core.protocols :as clojure.protocols] [methodical.impl.method-table.common :as method-table.common] [methodical.interface] [methodical.util.describe :as describe] [pretty.core :as pretty]) (:import (methodical.interface MethodTable))) | |
(set! *warn-on-reflection* true) | |
(comment methodical.interface/keep-me) | |
(deftype ClojureMethodTable [m]
pretty/PrettyPrintable
(pretty [_]
(if (seq m)
(list 'clojure-method-table (count m) 'primary)
'(clojure-method-table)))
Object
(equals [_ another]
(and (instance? ClojureMethodTable another)
(= m (.m ^ClojureMethodTable another))))
MethodTable
(primary-methods [_]
m)
(aux-methods [_]
nil)
(add-primary-method [this dispatch-val method]
(let [new-m (assoc m dispatch-val method)]
(if (= m new-m)
this
(ClojureMethodTable. new-m))))
(remove-primary-method [this dispatch-val]
(let [new-m (dissoc m dispatch-val)]
(if (= m new-m)
this
(ClojureMethodTable. new-m))))
(add-aux-method [_ _ _ _]
(throw (UnsupportedOperationException. "Clojure-style multimethods do not support auxiliary methods.")))
(remove-aux-method [_ _ _ _]
(throw (UnsupportedOperationException. "Clojure-style multimethods do not support auxiliary methods.")))
clojure.protocols/Datafiable
(datafy [this]
{:class (class this)
:primary (method-table.common/datafy-primary-methods m)})
describe/Describable
(describe [this]
(format "It uses the method table `%s`. These primary methods are known:\n\n%s"
(.getCanonicalName (class this))
(method-table.common/describe-primary-methods m)))) | |
(ns methodical.impl.method-table.common (:require [clojure.string :as str])) | |
(defn- datafy-method [f]
(let [mta (meta f)]
(cond-> mta
(:ns mta)
(update :ns ns-name)
(and (:name mta)
(:ns mta))
(update :name (fn [fn-name]
(symbol (str (ns-name (:ns mta))) (str fn-name))))
true
(dissoc :dispatch-value :private) ; we already know dispatch value. Whether it's private is irrelevant))) | |
Helper for datafying a map of dispatch value -> method. | (defn datafy-primary-methods
[dispatch-value->fn]
(into {}
(map (fn [[dispatch-value f]]
[dispatch-value (datafy-method f)]))
dispatch-value->fn)) |
(defn- datafy-methods [fns] (mapv datafy-method fns)) | |
Helper for datafying a map of qualifier -> dispatch value -> methods. | (defn datafy-aux-methods
[qualifier->dispatch-value->fns]
(into {}
(map (fn [[qualifier dispatch-value->fns]]
[qualifier (into {}
(map (fn [[dispatch-value fns]]
[dispatch-value (datafy-methods fns)]))
dispatch-value->fns)]))
qualifier->dispatch-value->fns)) |
(defn- describe-method
([f]
(let [{method-ns :ns, :keys [line file doc]} (meta f)]
(str/join
\space
[(when method-ns
(format "defined in [[%s]]" (ns-name method-ns)))
(cond
(and file line)
(format "(%s:%d)" file line)
file
(format "(%s)" file))
(when doc
(format "\n\nIt has the following documentation:\n\n%s" doc))])))
([dispatch-value f]
(format "* `%s`, %s" (pr-str dispatch-value) (str/join
"\n "
(str/split-lines (describe-method f)))))) | |
Helper for [[methodical.util.describe/describe]]ing the primary methods in a method table. | (defn describe-primary-methods
^String [dispatch-value->method]
(when (seq dispatch-value->method)
(format
"\n\nThese primary methods are known:\n\n%s"
(str/join
"\n\n"
(for [[dispatch-value f] dispatch-value->method]
(describe-method dispatch-value f)))))) |
Helper for [[methodical.util.describe/describe]]ing the aux methods in a method table. | (defn describe-aux-methods
^String [qualifier->dispatch-value->methods]
(when (seq qualifier->dispatch-value->methods)
(format
"\n\nThese aux methods are known:\n\n%s"
(str/join
"\n\n"
(for [[qualifier dispatch-value->methods] (sort-by first qualifier->dispatch-value->methods)]
(format
"`%s` methods:\n\n%s"
(pr-str qualifier)
(str/join
"\n\n"
(for [[dispatch-value fns] dispatch-value->methods
f fns]
(describe-method dispatch-value f))))))))) |
(ns methodical.impl.method-table.standard (:require [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 (methodical.interface MethodTable))) | |
(set! *warn-on-reflection* true) | |
(comment methodical.interface/keep-me) | |
Create a representation of | (defn- dispatch-value-map
[primary aux]
(not-empty
(merge
(when-let [dvs (not-empty (vec (sort (keys primary))))]
{:primary dvs})
(when-let [aux-methods (not-empty
(into {} (for [[qualifier dv->fns] aux
:let [dvs (for [[dv fns] dv->fns
_f fns]
dv)]
:when (seq dvs)]
[qualifier (vec (sort dvs))])))]
{:aux aux-methods})))) |
(deftype StandardMethodTable [primary aux]
pretty/PrettyPrintable
(pretty [_]
(if-let [m (not-empty (dispatch-value-map primary aux))]
(list 'standard-method-table m)
(list 'standard-method-table)))
Object
(equals [_ another]
(and (instance? StandardMethodTable another)
(= primary (.primary ^StandardMethodTable another))
(= aux (.aux ^StandardMethodTable another))))
MethodTable
(primary-methods [_]
primary)
(aux-methods [_]
aux)
(add-primary-method [this dispatch-val method]
(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))))
(remove-primary-method [this dispatch-val]
(let [new-primary (dissoc primary dispatch-val)]
(if (= primary new-primary)
this
(StandardMethodTable. new-primary aux))))
(add-aux-method [this qualifier dispatch-value method]
(let [new-aux (update-in aux
[qualifier dispatch-value]
(fn [existing-methods]
(if (contains? (set existing-methods) method)
existing-methods
(conj (vec existing-methods)
(u/fn-vary-meta method assoc :dispatch-value dispatch-value)))))]
(if (= aux new-aux)
this
(StandardMethodTable. primary new-aux))))
(remove-aux-method [this qualifier dispatch-value method]
(let [xforms [(fn [aux]
(update-in aux [qualifier dispatch-value] (fn [defined-methods]
(remove #(or (= % method)
(= (u/unwrap-fn-with-meta %) method))
defined-methods))))
(fn [aux]
(cond-> aux
(empty? (get-in aux [qualifier dispatch-value]))
(update qualifier dissoc dispatch-value)))
(fn [aux]
(cond-> aux
(empty? (get aux qualifier))
(dissoc qualifier)))]
new-aux (reduce (fn [aux xform] (xform aux)) aux xforms)]
(if (= aux new-aux)
this
(StandardMethodTable. primary new-aux))))
clojure.protocols/Datafiable
(datafy [this]
{:class (class this)
:primary (method-table.common/datafy-primary-methods primary)
:aux (method-table.common/datafy-aux-methods aux)})
describe/Describable
(describe [this]
(str (format "It uses the method table `%s`." (.getCanonicalName (class this)))
(method-table.common/describe-primary-methods primary)
(method-table.common/describe-aux-methods aux)))) | |
(ns methodical.impl.multifn.cached (:require [clojure.core.protocols :as clojure.protocols] [clojure.datafy :as datafy] [methodical.interface :as i] [methodical.util.describe :as describe] [pretty.core :as pretty]) (:import (clojure.lang Named) (methodical.interface Cache MultiFnImpl))) | |
(set! *warn-on-reflection* true) | |
(deftype CachedMultiFnImpl [^MultiFnImpl impl ^Cache cache]
pretty/PrettyPrintable
(pretty [_]
(list 'cached-multifn-impl impl cache))
Object
(equals [_ another]
(and (instance? CachedMultiFnImpl another)
(= impl (.impl ^CachedMultiFnImpl another))
;; TODO - does this make sense?
(= (class cache) (class (.cache ^CachedMultiFnImpl another)))))
Named
(getName [_]
(when (instance? Named impl)
(name impl)))
(getNamespace [_]
(when (instance? Named impl)
(namespace impl)))
MultiFnImpl
(method-combination [_]
(i/method-combination impl))
(dispatcher [_]
(.dispatcher impl))
(with-dispatcher [this new-dispatcher]
(let [new-impl (i/with-dispatcher impl new-dispatcher)]
(if (= impl new-impl)
this
(CachedMultiFnImpl. new-impl (i/empty-copy cache)))))
(method-table [_]
(i/method-table impl))
(with-method-table [this new-method-table]
(let [new-impl (i/with-method-table impl new-method-table)]
(if (= impl new-impl)
this
(CachedMultiFnImpl. new-impl (i/empty-copy cache)))))
(effective-method [_ dispatch-value]
(or
(.cached-method cache dispatch-value)
;; just like vanilla multimethods, we will add a new entry for every unique dispatch value we encounter, so
;; there's an implicit assumption that dispatch values are bounded
;;
;; build the effective method for dispatch value. We may end up throwing this out, but we currently need to build
;; it to determine the effective dispatch value.
(let [method (i/effective-method impl dispatch-value)
effective-dispatch-value (:dispatch-value (meta method))
;; If a method with the same effective dispatch value is already cached, add the existing method to the
;; cache for dispatch value. This way we don't end up with a bunch of duplicate methods impls for various
;; dispatch values that have the same effective dispatch value
cached-effective-dv-method (.cached-method cache effective-dispatch-value)
method (or cached-effective-dv-method method)]
;; Make sure the method was cached for the effective dispatch value as well, that way if some less-specific
;; dispatch value comes along with the same effective dispatch value we can use the existing method
(when-not cached-effective-dv-method
(i/cache-method! cache effective-dispatch-value method))
(i/cache-method! cache dispatch-value method)
method)))
clojure.protocols/Datafiable
(datafy [this]
(assoc (datafy/datafy impl)
:class (class this)
:cache (datafy/datafy cache)))
describe/Describable
(describe [_this]
(str (describe/describe cache)
\newline \newline
(describe/describe impl)))) | |
Standard Methodical MultiFn impl. | (ns methodical.impl.multifn.standard (:require [clojure.core.protocols :as clojure.protocols] [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 (methodical.interface Dispatcher MethodCombination MethodTable MultiFnImpl))) |
(set! *warn-on-reflection* true) | |
"composite dispatch value" below just means a dispatch value consisting of multiple parts e.g. | |
Sort dispatch values in order from most-specific-overall to least-specific-overall. | (defn sort-dispatch-values [dispatcher dispatch-values] (sort-by identity (dispatcher.common/domination-comparator (partial i/dominates? dispatcher)) dispatch-values)) |
Operates only on non-composite dispatch values. Determine the effective (most-specific) dispatch value that will be
used when dispatching on Example. Suppose a | (defn non-composite-effective-dispatch-value
[dispatcher actual-dispatch-value method-dispatch-values]
(let [[most-specific-dispatch-value & more-dispatch-values] (distinct (sort-dispatch-values dispatcher method-dispatch-values))
;; do not take preferences into account when calculating the effective dispatch value. Aux methods are applied
;; to *all* matching dispatch values, which means that one aux method should not be considered unambiguously
;; dominant over another based on preferences alone; we should only consider a method to be dominant over
;; another for effective dispatch value purposes if its dispatch value ISA all of the other matching dispatch
;; values.
;;
;; Example: if a `:toucan` ISA `:can` and a `:toucan` ISA `:bird`, and we have `:before` methods for both
;; `:can` and `:bird`, and a preference for `:bird` over `:can`, we cannot consider `:bird` to be the
;; effective dispatch value for `:toucan`, because a `:toucan` ISA `:can`, but a `:bird` is not a `:can`.
dispatcher (i/with-prefers dispatcher nil)]
(if (every? (fn [another-dispatch-value]
(i/dominates? dispatcher most-specific-dispatch-value another-dispatch-value))
more-dispatch-values)
most-specific-dispatch-value
actual-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. ```clj ;; 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. | (defn composite-effective-dispatch-value
[dispatcher actual-dispatch-value method-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-method-dispatch-value :as method-dispatch-values] (sort-dispatch-values dispatcher method-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-method-dispatch-value)
(non-composite-effective-dispatch-value dispatcher actual-dispatch-value method-dispatch-values)
;; otherwise we need to combine stuff
(mapv (fn [i]
(non-composite-effective-dispatch-value dispatcher
(nth actual-dispatch-value i)
(map #(nth % i)
(filter sequential? method-dispatch-values))))
(range (count actual-dispatch-value)))))) |
Given matching | (defn effective-dispatch-value
[dispatcher actual-dispatch-value primary-methods aux-methods]
(let [dispatch-values (transduce
(comp cat
(map meta)
(filter #(contains? % :dispatch-value))
(map :dispatch-value))
conj
[]
(cons primary-methods (vals aux-methods)))]
(composite-effective-dispatch-value dispatcher actual-dispatch-value dispatch-values))) |
Build an effective method using the 'standard' technique, taking the dispatch-value-method pairs in the
| (defn standard-effective-method
[method-combination dispatcher method-table dispatch-value]
(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)
(u/fn-with-meta {:dispatch-value (effective-dispatch-value dispatcher dispatch-value primary-methods aux-methods)})))) |
(deftype StandardMultiFnImpl [^MethodCombination combo
^Dispatcher dispatcher
^MethodTable method-table]
pretty/PrettyPrintable
(pretty [_this]
(list 'standard-multifn-impl combo dispatcher method-table))
Object
(equals [_ another]
(and (instance? StandardMultiFnImpl another)
(let [^StandardMultiFnImpl another another]
(and (= combo (.combo another))
(= dispatcher (.dispatcher another))
(= method-table (.method-table another))))))
MultiFnImpl
(method-combination [_this]
combo)
(dispatcher [_this]
dispatcher)
(with-dispatcher [this new-dispatcher]
(if (= dispatcher new-dispatcher)
this
(StandardMultiFnImpl. combo new-dispatcher method-table)))
(method-table [_this]
method-table)
(with-method-table [this new-method-table]
(if (= method-table new-method-table)
this
(StandardMultiFnImpl. combo dispatcher new-method-table)))
(effective-method [_this dispatch-value]
(standard-effective-method combo dispatcher method-table dispatch-value))
clojure.protocols/Datafiable
(datafy [this]
{:class (class this)
:combo (datafy/datafy combo)
:dispatcher (datafy/datafy dispatcher)
:method-table (datafy/datafy method-table)})
describe/Describable
(describe [_this]
(str (describe/describe combo)
\newline \newline
(describe/describe dispatcher)
\newline \newline
(describe/describe method-table)))) | |
(ns methodical.impl.standard (:require [clojure.core.protocols :as clojure.protocols] [clojure.datafy :as datafy] [methodical.interface :as i] [methodical.util.describe :as describe] [pretty.core :as pretty]) (:import (clojure.lang Named) (methodical.interface Dispatcher MethodCombination MethodTable MultiFnImpl))) | |
(set! *warn-on-reflection* true) | |
(defn- maybe-name [^MultiFnImpl impl]
(if-let [nm (and (instance? Named impl) (name impl))]
(str " " nm))) | |
(defn- handle-effective-method-exception [^Exception e mta]
(if-let [dispatch-val (::unmatched-dispatch-value (ex-data e))]
(throw (UnsupportedOperationException.
(format "No matching%s method for dispatch value %s" (if-let [nm (:name mta)]
(str " " nm))
(pr-str dispatch-val))))
;; this wasn't an :unmatched-dispatch-value situation; just rethrow it
(throw e))) | |
(defn- ^:static effective-method [^MultiFnImpl impl dispatch-value]
(or (.effective-method impl dispatch-value)
(throw
(ex-info (format "No matching%s method for dispatch value %s" (maybe-name impl) (pr-str dispatch-value))
{::unmatched-dispatch-value dispatch-value})))) | |
Utility macro for finding the effective method of | (defmacro ^:private invoke-multi
[impl mta & args]
`(try
(let [em# (effective-method ~impl (.dispatch-value ^Dispatcher (.dispatcher ~impl) ~@args))]
(em# ~@args))
(catch Exception e#
(handle-effective-method-exception e# ~mta)))) |
(defn- ^:static invoke-multifn
([^MultiFnImpl impl mta]
(invoke-multi impl mta))
([^MultiFnImpl impl mta a]
(invoke-multi impl mta a))
([^MultiFnImpl impl mta a b]
(invoke-multi impl mta a b))
([^MultiFnImpl impl mta a b c]
(invoke-multi impl mta a b c))
([^MultiFnImpl impl mta a b c d]
(invoke-multi impl mta a b c d))
([^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 e f g more))
a b c d e f g more)
(catch Exception e
(handle-effective-method-exception e mta))))) | |
(deftype StandardMultiFn [^MultiFnImpl impl mta]
pretty/PrettyPrintable
(pretty [_]
(list 'multifn impl))
Object
(equals [_ another]
(and (instance? StandardMultiFn another)
(= impl (.impl ^StandardMultiFn another))))
Named
(getName [_] (some-> (:name mta) name))
(getNamespace [_] (some-> (:ns mta) ns-name name))
clojure.lang.IObj
(meta [_]
mta)
(withMeta [this new-meta]
(if (= mta new-meta)
this
(StandardMultiFn. impl new-meta)))
MethodCombination
(allowed-qualifiers [_]
(i/allowed-qualifiers (i/method-combination impl)))
(combine-methods [_ primary-methods aux-methods]
(i/combine-methods (i/method-combination impl) primary-methods aux-methods))
(transform-fn-tail [_ qualifier fn-tail]
(i/transform-fn-tail (i/method-combination impl) qualifier fn-tail))
Dispatcher
(dispatch-value [_]
(.dispatch-value ^Dispatcher (.dispatcher impl)))
(dispatch-value [_ a]
(.dispatch-value ^Dispatcher (.dispatcher impl) a))
(dispatch-value [_ a b]
(.dispatch-value ^Dispatcher (.dispatcher impl) a b))
(dispatch-value [_ a b c]
(.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 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))
(matching-aux-methods [_ method-table dispatch-value]
(i/matching-aux-methods (.dispatcher impl) method-table dispatch-value))
(default-dispatch-value [_]
(i/default-dispatch-value (.dispatcher impl)))
(prefers [_]
(i/prefers (.dispatcher impl)))
(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))
MethodTable
(primary-methods [_]
(i/primary-methods (i/method-table impl)))
(aux-methods [_]
(i/aux-methods (i/method-table impl)))
(add-primary-method [this dispatch-val method]
(i/with-method-table this (i/add-primary-method (i/method-table impl) dispatch-val method)))
(remove-primary-method [this dispatch-val]
(i/with-method-table this (i/remove-primary-method (i/method-table impl) dispatch-val)))
(add-aux-method [this qualifier dispatch-val method]
(i/with-method-table this (i/add-aux-method (i/method-table impl) qualifier dispatch-val method)))
(remove-aux-method [this qualifier dispatch-val method]
(i/with-method-table this (i/remove-aux-method (i/method-table impl) qualifier dispatch-val method)))
MultiFnImpl
(method-combination [_]
(i/method-combination impl))
(dispatcher [_]
(.dispatcher impl))
(with-dispatcher [this new-dispatcher]
(assert (instance? Dispatcher new-dispatcher))
(if (= (.dispatcher impl) new-dispatcher)
this
(StandardMultiFn. (i/with-dispatcher impl new-dispatcher) mta)))
(method-table [_]
(i/method-table impl))
(with-method-table [this new-method-table]
(assert (instance? MethodTable new-method-table))
(if (= (i/method-table impl) new-method-table)
this
(StandardMultiFn. (i/with-method-table impl new-method-table) mta)))
(effective-method [_this dispatch-value]
(try (.effective-method impl dispatch-value)
(catch Exception e
(handle-effective-method-exception e mta))))
java.util.concurrent.Callable
(call [_]
(invoke-multifn impl mta))
java.lang.Runnable
(run [_]
(invoke-multifn impl mta))
clojure.lang.IFn
(invoke [_]
(invoke-multifn impl mta))
(invoke [_ a]
(invoke-multifn impl mta a))
(invoke [_ a b]
(invoke-multifn impl mta a b))
(invoke [_ a b c]
(invoke-multifn impl mta a b c))
(invoke [_ a b c d]
(invoke-multifn impl mta a b c d))
(invoke [_ a b c d e]
(invoke-multifn impl mta a b c d e))
(invoke [_ a b c d e f]
(invoke-multifn impl mta a b c d e f))
(invoke [_ a b c d e f g]
(invoke-multifn impl mta a b c d e f g))
(invoke [_ a b c d e f g h]
(invoke-multifn impl mta a b c d e f g h))
(invoke [_ a b c d e f g h i]
(invoke-multifn impl mta a b c d e f g h i))
(invoke [_ a b c d e f g h i j]
(invoke-multifn impl mta a b c d e f g h i j))
(invoke [_ a b c d e f g h i j k]
(invoke-multifn impl mta a b c d e f g h i j k))
(invoke [_ a b c d e f g h i j k l]
(invoke-multifn impl mta a b c d e f g h i j k l))
(invoke [_ a b c d e f g h i j k l m]
(invoke-multifn impl mta a b c d e f g h i j k l m))
(invoke [_ a b c d e f g h i j k l m n]
(invoke-multifn impl mta a b c d e f g h i j k l m n))
(invoke [_ a b c d e f g h i j k l m n o]
(invoke-multifn impl mta a b c d e f g h i j k l m n o))
(invoke [_ a b c d e f g h i j k l m n o p]
(invoke-multifn impl mta a b c d e f g h i j k l m n o p))
(invoke [_ a b c d e f g h i j k l m n o p q]
(invoke-multifn impl mta a b c d e f g h i j k l m n o p q))
(invoke [_ a b c d e f g h i j k l m n o p q r]
(invoke-multifn impl mta a b c d e f g h i j k l m n o p q r))
(invoke [_ a b c d e f g h i j k l m n o p q r s]
(invoke-multifn impl mta a b c d e f g h i j k l m n o p q r s))
(invoke [_ a b c d e f g h i j k l m n o p q r s t]
(invoke-multifn impl mta a b c d e f g h i j k l m n o p q r s t))
(invoke [_ a b c d e f g h i j k l m n o p q r s t args]
(apply invoke-multifn impl mta a b c d e f g h i j k l m n o p q r s t args))
(applyTo [_ args]
(apply invoke-multifn impl mta args))
clojure.protocols/Datafiable
(datafy [this]
(with-meta (merge (datafy/datafy impl)
(select-keys mta [:name :arglists :file :column :line])
(when (:ns mta)
{:ns (ns-name (:ns mta))})
(when (and (:ns mta) (:name mta))
{:name (symbol (str (ns-name (:ns mta))) (str (:name mta)))})
{:class (class this)})
mta))
describe/Describable
(describe [_this]
(let [{mf-name :name, mf-ns :ns, :keys [file line]} mta]
(str (pr-str mf-name)
(let [message (str
(when mf-ns
(format "[[%s]]" (ns-name mf-ns)))
(cond
(and file line) (format " (%s:%d)" file line)
file (str \space file)
:else ))]
(when (seq message)
(format " is defined in %s." message)))
\newline \newline
(describe/describe impl))))) | |
True if | (defn multifn? [x] (instance? StandardMultiFn x)) |
(ns methodical.interface (:refer-clojure :exclude [isa? prefers]) (:require clojure.core)) | |
(set! *warn-on-reflection* true) | |
this is a dummy dependency until Cloverage 1.3.0 is released -- see https://github.com/cloverage/cloverage/issues/318 | (comment clojure.core/keep-me) |
A method combination defines the way applicable primary and auxiliary methods are combined into a single *effective
method. Method combinations also specify which auxiliary method *qualifiers (e.g. | (defprotocol MethodCombination
(allowed-qualifiers [method-combination]
"The set containing all qualifiers supported by this method combination. `nil` in the set means the method
combination supports primary methods (because primary methods have no qualifier); all other values refer to auxiliary
methods with that qualifier, e.g. `:before`, `:after`, or `:around`.
```clj
(allowed-qualifiers (clojure-method-combination)) ;-> #{nil}
(allowed-qualifiers (clos-method-combination)) ;-> #{nil :before :after :around}
(allowed-qualifiers (doseq-method-combination)) ;-> #{:doseq}
```")
(combine-methods [method-combination primary-methods aux-methods]
"Combine a sequence of matching `primary-methods` with `aux-methods` (a map of qualifier -> sequence of methods)
into a single effective method. Method includes effective `^:dispatch-value` metadata.")
(transform-fn-tail [method-combination qualifier fn-tail]
"Make appropriate transformations to the `fn-tail` of a [[methodical.macros/defmethod]] macro expansion for a
primary method (qualifier will be `nil`) or an auxiliary method. You can use this method to add implicit args like
`next-method` to the body of a `defmethod` macro. (Because this method is invoked during macroexpansion, it should
return a Clojure form.)")) |
A method table stores primary and auxiliary methods, and returns them when asked. The default implementation, [[methodical.impl/standard-method-table]], uses simple Clojure immutable maps. | (defprotocol MethodTable
(primary-methods [method-table]
"Get a `dispatch-value -> fn` map of all primary methods associated with this method table.")
(aux-methods [method-table]
"Get a `qualifier -> dispatch-value -> [fn]` map of all auxiliary methods associated with this method table.")
(add-primary-method ^methodical.interface.MethodTable [method-table dispatch-value f]
"Set the primary method implementation for `dispatch-value`, replacing it if it already exists.")
(remove-primary-method ^methodical.interface.MethodTable [method-table dispatch-value]
"Remove the primary method for `dispatch-value`.")
(add-aux-method ^methodical.interface.MethodTable [method-table qualifier dispatch-value f]
"Add an auxiliary method implementation for `qualifier` (e.g. `:before`) and `dispatch-value`. Unlike primary
methods, auxiliary methods are not limited to one method per dispatch value; thus this method does not remove
existing methods for this dispatch value.")
(remove-aux-method ^methodical.interface.MethodTable [method-table qualifier dispatch-val method]
"Remove an auxiliary method from a method table. Because multiple auxiliary methods are allowed for the same
dispatch value, existing implementations of `MethodTable` are currently only able to remove exact matches -- for
functions, this usually means identical objects.
In the future, I hope to fix this by storing unique identifiers in the metadata of methods in the map.")) |
A dispatcher decides which dispatch value should be used for a given set of arguments, which primary and
auxiliary methods from the method table are applicable for that dispatch value, and the order those methods should
be applied in -- which methods are most specific, and which are the least specific (e.g., | (defprotocol Dispatcher
(dispatch-value
[dispatcher]
[dispatcher a]
[dispatcher a b]
[dispatcher a b c]
[dispatcher a b c d]
[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.)")
(matching-primary-methods [dispatcher method-table dispatch-value]
"Return a sequence of applicable primary methods for `dispatch-value`, sorted from most-specific to
least-specific. Methods should have the `^:dispatch-value` with which they were defined as metadata. The standard
dispatcher also checks to make sure methods in the sequence are not ambiguously specific, replacing ambiguous
methods with ones that will throw an Exception when invoked.")
(matching-aux-methods [dispatcher method-table dispatch-value]
"Return a map of aux method qualifier -> sequence of applicable methods for `dispatch-value`, sorted from
most-specific to least-specific. Methods should have the `^:dispatch-value` with which they were defined as
metadata.")
(default-dispatch-value [dispatcher]
"Default dispatch value to use if no other dispatch value matches.")
(prefers [dispatcher]
"Return a map of preferred dispatch value -> set of other dispatch values.")
(^methodical.interface.Dispatcher ^{:style/indent :defn} 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`?")) |
Protocol for a complete Methodical multimethod, excluding the optional cache (multimethods with caching wrap a
| (defprotocol MultiFnImpl
(^methodical.interface.MethodCombination method-combination [multifn]
"Get the method combination associated with this multifn.")
(^methodical.interface.Dispatcher dispatcher [multifn]
"Get the dispatcher associated with this multifn.")
(^methodical.interface.MultiFnImpl ^{:style/indent :defn} with-dispatcher [multifn new-dispatcher]
"Return a copy of this multifn using `new-dispatcher` as its dispatcher.")
(^methodical.interface.MethodTable method-table [multifn]
"Get the method table associated with this multifn.")
(^methodical.interface.MultiFnImpl ^{:style/indent :defn} with-method-table [multifn new-method-table]
"Return a copy of this multifn using `new-method-table` as its method table.")
(effective-method [multifn dispatch-value]
"Return the effective method for `dispatch-value`. The effective method is a combined primary method and applicable
auxiliary methods that can be called like a normal function. [[effective-method]] is similar in purpose
to [[clojure.core/get-method]] in vanilla Clojure multimethods; a different name is used here because I felt
`get-method` would be ambiguous with regards to whether it returns only a primary method or a combined effective
method.")) |
A cache, if present, implements a caching strategy for effective methods, so that they need not be recomputed on every invocation. | (defprotocol Cache
(cached-method [cache dispatch-value]
"Return cached effective method for `dispatch-value`, if it exists in the cache.")
(cache-method! [cache dispatch-value method]
"Cache the effective method for `dispatch-value` in this cache.")
(clear-cache! [cache]
"Empty the contents of the cache in-place.")
(^methodical.interface.Cache empty-copy [cache]
"Return an empty copy of the same type as this cache, e.g. for use when copying a multifn.")) |
Methodical versions of vanilla Clojure [[defmulti]] and [[defmethod]] macros. | (ns methodical.macros (:refer-clojure :exclude [defmulti defmethod]) (:require [clojure.core.specs.alpha] [clojure.spec.alpha :as s] [clojure.string :as str] [methodical.impl :as impl] [methodical.interface :as i] [methodical.macros.validate-arities :as validate-arities] [methodical.util :as u]) (:import (methodical.impl.standard StandardMultiFn))) |
(set! *warn-on-reflection* true) | |
(comment clojure.core.specs.alpha/keep-me) ; for the specs below | |
(s/def ::fn-tail
(s/alt :arity-1 :clojure.core.specs.alpha/params+body
:arity-n (s/+ (s/spec :clojure.core.specs.alpha/params+body)))) | |
(s/def :methodical.macros.defmulti.attr-map/dispatch-value-spec ;; not sure how to validate this. Is there a predicate for something that can be used as a ;; spec? [[clojure.spec.alpha/spec]] will happily turn random things into specs for us any?) | |
(s/def :methodical.macros.defmulti.attr-map/defmethod-arities (s/nilable ::validate-arities/arities-set)) | |
(s/def :methodical.macros.defmulti/attr-map
(s/keys :opt-un [:methodical.macros.defmulti.attr-map/dispatch-value-spec
:methodical.macros.defmulti.attr-map/defmethod-arities])) | |
(s/def ::defmulti-args
(s/& (s/cat :name-symb (every-pred symbol? (complement namespace))
:docstring (s/? string?)
:attr-map (s/? map?)
:dispatch-fn (s/? any?)
:options (s/* (s/cat :k keyword?
:v any?)))
;; do a "soft" cut here where any map argument is always interpreted as an attribute map, and only later subject
;; it to stricter validation. See my questions in Slack here
;; https://clojurians.slack.com/archives/C1B1BB2Q3/p1662755403589769
(s/keys :opt-un [:methodical.macros.defmulti/attr-map]))) | |
Impl for the [[defmulti]] macro. | (defmacro ^:no-doc redefine-multimethod
[name-symb dispatch-fn {:keys [hierarchy dispatcher combo method-table cache default-value]
:or {combo `(impl/thread-last-method-combination)
method-table `(impl/standard-method-table)
cache (if hierarchy
`(impl/watching-cache (impl/simple-cache) [~hierarchy])
`(impl/simple-cache))
hierarchy '#'clojure.core/global-hierarchy}
prefs :prefers}]
(let [dispatch-fn (or dispatch-fn `identity)
dispatcher (or dispatcher
`(impl/multi-default-dispatcher ~dispatch-fn
:hierarchy ~hierarchy
~@(when default-value
[:default-value default-value])
~@(when prefs
[:prefers prefs])))
;; attach the var metadata to the multimethod itself as well so we can use it for cool stuff e.g.
;; `:dispatch-value-spec` or `:arglists`.
mta (merge (meta name-symb)
{:ns *ns*, :name (list 'quote (with-meta name-symb nil))})]
`(def ~name-symb
(let [impl# (impl/standard-multifn-impl ~combo ~dispatcher ~method-table)]
(vary-meta (impl/multifn impl# ~mta ~cache) merge (meta (var ~name-symb))))))) |
Part of the implementation for [[defmulti]]. Don't call this directly. | (defn ^:no-doc update-multimethod-metadata!
[varr new-metadata]
(let [new-doc (u/docstring-with-describe-output-appended (:doc new-metadata) (var-get varr))]
(letfn [(merge-metadata [old-metadata]
(merge (select-keys old-metadata [:ns :name :file :line :column])
new-metadata
{:original-doc (:doc new-metadata)
:doc new-doc}))]
(alter-meta! varr merge-metadata)
;; update the metadata on the multifn itself too.
(alter-var-root varr (fn [multifn]
(vary-meta multifn merge-metadata)))))
varr) |
Creates a new Methodical multimethod named by a Var. Usage of this macro mimics usage of [[clojure.core/defmulti]],
and it can be used as a drop-in replacement; it does, however, support a larger set of options. Note the dispatch-fn
is optional (if omitted, then identity will be used). In addition to the usual
The above options comprise the main constituent parts of a Methodical multimethod, and the majority of those parts have several alternative implementations available in [[methodical.impl]]. Defining additional implementations is straightforward as well: see [[methodical.interface]] for more details. Other improvements over [[clojure.core/defmulti]]:
Attribute map options:
| (defmacro defmulti
{:arglists '([name-symb docstring? attr-map? dispatch-fn?
& {:keys [hierarchy default-value prefers combo method-table cache]}]
[name-symb docstring? attr-map? & {:keys [dispatcher combo method-table cache]}])
:style/indent :defn}
[name-symb & args]
(let [varr (ns-resolve *ns* name-symb)
{:keys [docstring attr-map dispatch-fn options]} (s/conform ::defmulti-args (cons name-symb args))
options (into {} (map (juxt :k :v)) options)
metadata (merge {:tag methodical.impl.standard.StandardMultiFn}
(when docstring {:doc docstring})
attr-map)
old-val (some->> varr deref (instance? StandardMultiFn))
old-hash (when old-val
(-> varr meta ::defmulti-hash))
;; hash should not include any metadata... do not redefine a multimethod if only metadata changes
current-hash (hash {:dispatch-fn dispatch-fn
:options options})
metadata (assoc metadata ::defmulti-hash current-hash)
name-symb (vary-meta name-symb merge metadata)]
;; hashes and the like are expanded out into the macro to make what's going on more obvious when you expand it
`(let [skip-redef?# (and
(let [~'old-hash ~old-hash
~'current-hash ~current-hash]
(= ~'old-hash ~'current-hash))
(some-> (ns-resolve *ns* '~name-symb) deref u/multifn?))]
(if-not skip-redef?#
(redefine-multimethod ~name-symb ~dispatch-fn ~options)
(update-multimethod-metadata! (var ~name-symb) ~(merge (meta name-symb) metadata)))))) |
(s/fdef defmulti :args ::defmulti-args :ret any?) | |
[[defmethod]] | |
A dispatch value as parsed to [[defmethod]] (i.e., not-yet-evaluated) can be ANYTHING other than the following two things:
Note that if you specify a custom | (defn- default-dispatch-value-spec
[allowed-aux-qualifiers]
(fn valid-dispatch-value? [x]
(and (not (contains? allowed-aux-qualifiers x))
(or (not (seq? x))
(not (s/valid? :clojure.core.specs.alpha/params+body x)))))) |
Generate a name based on a dispatch value. Used by [[method-fn-symbol]] below. | (defn- dispatch-val-name
[dispatch-val]
(let [s (cond
(sequential? dispatch-val)
(str/join "-" (map dispatch-val-name dispatch-val))
(and (instance? clojure.lang.Named dispatch-val)
(namespace dispatch-val))
(str (namespace dispatch-val) "-" (name dispatch-val))
(instance? clojure.lang.Named dispatch-val)
(name dispatch-val)
:else
(munge (str dispatch-val)))]
(-> s
(str/replace #"\s+" "-")
(str/replace #"\." "-")))) |
Generate a nice name for a primary or auxiliary method's implementing function. Named functions are used rather than anonymous functions primarily to aid in debugging and improve stacktraces. | (defn- method-fn-symbol
([multifn qualifier dispatch-val]
(method-fn-symbol multifn qualifier dispatch-val nil))
([multifn qualifier dispatch-val unique-key]
(let [s (cond-> (format "%s-%s-method-%s" (name multifn) (name qualifier) (dispatch-val-name dispatch-val))
unique-key
(str "-" unique-key))]
(vary-meta (symbol s) assoc :private true, :multifn (when-let [ns-symb (some-> (:ns (meta multifn)) ns-name name)]
(when-let [symb (some-> (:name (meta multifn)) name)]
(list 'var (symbol ns-symb symb)))))))) |
Impl for [[defmethod]] for primary methods. | (defn- emit-primary-method
[multifn {:keys [multifn-symb dispatch-value docstring fn-tail]}]
(let [fn-symb (method-fn-symbol multifn "primary" dispatch-value)]
`(do
(defn ~fn-symb
~@(when docstring
[docstring])
~@(i/transform-fn-tail multifn nil fn-tail))
(u/add-primary-method! (var ~multifn-symb) ~dispatch-value (u/fn-vary-meta ~fn-symb merge (meta (var ~fn-symb))))))) |
Impl for [[defmethod]] for aux methods. | (defn- emit-aux-method
[multifn {:keys [multifn-symb qualifier dispatch-value unique-key docstring fn-tail]}]
(let [fn-symb (method-fn-symbol multifn qualifier dispatch-value unique-key)
unique-key (or unique-key (list 'quote (ns-name *ns*)))]
`(do
(defn ~fn-symb
~@(when docstring
[docstring])
~@(i/transform-fn-tail multifn qualifier fn-tail))
(u/add-aux-method-with-unique-key! (var ~multifn-symb)
~qualifier
~dispatch-value
(u/fn-vary-meta ~fn-symb merge (meta (var ~fn-symb)))
~unique-key)))) |
(defn- defmethod-args-spec [multifn]
(let [allowed-qualifiers (i/allowed-qualifiers multifn)
primary-methods-allowed? (contains? allowed-qualifiers nil)
allowed-aux-qualifiers (disj allowed-qualifiers nil)
dispatch-value-spec (or (some-> (get (meta multifn) :dispatch-value-spec) s/spec)
(default-dispatch-value-spec allowed-aux-qualifiers))
arities-spec (validate-arities/allowed-arities-fn-tail-spec (:defmethod-arities (meta multifn)))]
(s/cat :args-for-method-type (s/alt :primary (if primary-methods-allowed?
(s/cat :dispatch-value dispatch-value-spec)
(constantly false))
:aux (s/cat :qualifier allowed-aux-qualifiers
:dispatch-value dispatch-value-spec
:unique-key (s/? (complement (some-fn string? sequential?)))))
:docstring (s/? string?)
:fn-tail (s/& (s/+ any?)
(s/nonconforming (s/& ::fn-tail arities-spec)))))) | |
(defn- parse-defmethod-args [multifn args]
(let [spec (defmethod-args-spec multifn)
conformed (s/conform spec args)]
(if (s/invalid? conformed)
(throw (ex-info (s/explain-str spec args) (s/explain-data spec args)))
(let [{[method-type type-args] :args-for-method-type} conformed]
(-> (merge conformed {:method-type method-type} type-args)
(dissoc :args-for-method-type)))))) | |
(defn- resolve-multifn [multifn-symb]
(doto (some-> (resolve multifn-symb) deref)
(assert (format "Could not resolve multifn %s" multifn-symb)))) | |
Define a new multimethod method implementation. Syntax is the same as for vanilla Clojure [[defmethod]], but you may also define auxiliary methods by passing an optional auxiliary method qualifier before the dispatch value: ```clj ;; define a new primary method (defmethod some-multifn Bird [_] ...) ;; define a new auxiliary method (defmethod some-multifn :before Toucan [_] ...) ``` | (defmacro defmethod
{:arglists '([multifn-symb dispatch-val docstring? & fn-tail]
[multifn-symb aux-qualifier dispatch-val unique-key? docstring? & fn-tail])
:style/indent :defn}
[multifn-symb & args]
(let [multifn (resolve-multifn multifn-symb)
parsed-args (assoc (parse-defmethod-args multifn args) :multifn multifn, :multifn-symb multifn-symb)]
((case (:method-type parsed-args)
:aux emit-aux-method
:primary emit-primary-method) multifn parsed-args))) |
(s/fdef defmethod
:args (s/& (s/cat :multifn-symb (every-pred symbol? resolve)
:args (s/+ any?))
;; not sure if there's an easier way to do this.
(fn [{:keys [multifn-symb args]}]
(let [multifn (resolve-multifn multifn-symb)
spec (defmethod-args-spec multifn)
conformed (s/conform spec args)]
(when (s/invalid? conformed)
(throw (ex-info (s/explain-str spec args) (s/explain-data spec args))))
true)))
:ret any?) | |
Implementation for The arities sets passed around here are sets of numeric arity counts, or ```clj (fn ([x]) ([x y & more])) ``` has the arities | (ns ^:no-doc methodical.macros.validate-arities (:require [clojure.data :as data] [clojure.set :as set] [clojure.spec.alpha :as s])) |
(defn- int-between-zero-and-twenty-inclusive? [n]
(and (integer? n)
(<= 0 n 20))) | |
(s/def ::arities-set
(s/every
(s/or :int int-between-zero-and-twenty-inclusive?
:>=-form (s/spec (s/cat :>= (partial = :>=)
:int int-between-zero-and-twenty-inclusive?)))
:kind set?
:min-count 1)) | |
Determine the arity sets for ```clj (arglist-arities (s/conform (s/+ :clojure.core.specs.alpha/param-list) '([] [x]))) => #{0 1} (arglist-arities (s/conform (s/+ :clojure.core.specs.alpha/param-list) '([] [x] [x y z & more]))) => #{0 1 [:>= 3]} ``` | (defn- arglist-arities
[arglists]
(into #{}
(map (fn [{:keys [params var-params]}]
(if var-params
[:>= (count params)]
(count params))))
arglists)) |
Determine arity sets for ```clj (fn-tail-arities (s/conform :methodical.macros/fn-tail '[([x] x) ([x y & more] x)])) => {1 [:>= 2]}``` | (defn- fn-tail-arities
[[arity-type x]]
(set (case arity-type
:arity-1 (arglist-arities [(:params x)])
:arity-n (arglist-arities (map :params x))))) |
Given an arity like
```clj (expand-arity 1) => #{1} (expand-arity [:> 3]) => #{3 4 5 6 7 8 9 ... :more} ``` | (defn- expand-arity
[arity]
(if (integer? arity)
(sorted-set arity)
(let [[_ arity] arity]
(into #{:more} (range arity 21))))) |
(defn- expand-arities [arities]
(into #{} (mapcat expand-arity) arities)) | |
Given a set of | (defn- diff-arities
[required actual]
(let [[missing disallowed] (data/diff (expand-arities required) (expand-arities actual))]
(not-empty
(into {} (for [[k orig expanded] [[:required required missing]
[:disallowed actual disallowed]]
:when (seq expanded)]
[k (set (for [arity orig
:when (not-empty (set/intersection (expand-arity arity) expanded))]
arity))]))))) |
Create a spec for a function tail to make sure it has all of the | (defn allowed-arities-fn-tail-spec
[required-arities]
(if (empty? required-arities)
identity
(s/and (s/conformer (fn [fn-tail]
(let [arities (fn-tail-arities fn-tail)
diff (diff-arities required-arities arities)]
(when (seq diff)
{:arities diff}))))
empty?))) |
Utility functions for performing additional operations on multifns and their components not specified in one of the interfaces. These functions are compositions of those methods. | (ns methodical.util (:refer-clojure :exclude [prefers prefer-method remove-all-methods]) (:require [methodical.impl.standard :as impl.standard] [methodical.interface :as i] [methodical.util.describe :as describe])) |
(set! *warn-on-reflection* true) | |
True if | (defn multifn? [x] (impl.standard/multifn? x)) |
(declare unwrap-fn-with-meta) | |
Generate FnWithMeta deftype declaration. | (defmacro generate-FnWithMeta
[]
(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) | |
If the provided argument is a FnWithMeta object, extract the function it wraps, otherwise return the argument. | (defn unwrap-fn-with-meta
[fun]
(if (instance? FnWithMeta fun)
(.fn ^FnWithMeta fun)
fun)) |
Construct a new FnWithMeta from the provided arguments. Unwrap | (defn fn-with-meta [fun mta] (->FnWithMeta (unwrap-fn-with-meta fun) mta)) |
Construct a new FnWithMeta with the same underlying function (possibly unwrapped) but with the meta that is the result
of | (defn fn-vary-meta [fun f & args] (fn-with-meta (unwrap-fn-with-meta fun) (apply f (meta fun) args))) |
Get the primary method explicitly specified for Note that the primary method will not have any implicit args (e.g. | (defn primary-method [multifn dispatch-val] (get (i/primary-methods multifn) dispatch-val)) |
Return a sequence of applicable primary methods for | (defn matching-primary-methods ([multifn dispatch-val] (i/matching-primary-methods multifn multifn dispatch-val)) ([dispatcher method-table dispatch-val] (i/matching-primary-methods dispatcher method-table dispatch-val))) |
Return the primary method that would be use for Like [[primary-method]], the method returned will not have any implicit args (such as | (defn applicable-primary-method [multifn dispatch-val] (first (matching-primary-methods multifn dispatch-val))) |
Build and effective method equivalent that would be used for this | (defn effective-primary-method
[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)
(fn-with-meta (meta most-specific-primary-method))))) |
Get all auxiliary methods explicitly specified for
| (defn aux-methods
([multifn]
(i/aux-methods multifn))
([multifn dispatch-val]
(let [qualifier->dispatch-val->fns (i/aux-methods multifn)]
(when (seq qualifier->dispatch-val->fns)
(into {} (for [[qualifier dispatch-val->fns] qualifier->dispatch-val->fns
:let [fns (get dispatch-val->fns dispatch-val)]
:when (seq fns)]
[qualifier fns])))))
([multifn qualifier dispatch-val]
(get-in (i/aux-methods multifn) [qualifier dispatch-val]))) |
Return a map of aux method qualifier -> sequence of applicable methods for | (defn matching-aux-methods ([multifn dispatch-val] (i/matching-aux-methods multifn multifn dispatch-val)) ([dispatcher method-table dispatch-val] (i/matching-aux-methods dispatcher method-table dispatch-val))) |
Get the default primary method associated with this | (defn default-primary-method [multifn] (primary-method multifn (i/default-dispatch-value multifn))) |
Get a map of aux qualifier -> methods for the default dispatch value, if any exist. | (defn default-aux-methods [multifn] (aux-methods multifn (i/default-dispatch-value multifn))) |
Return the effective (combined) method for the default dispatch value, if one can be computed. | (defn default-effective-method [multifn] (i/effective-method multifn (i/default-dispatch-value multifn))) |
Return the least-specific dispatch value that would return the same effective method as | (defn effective-dispatch-value [multifn dispatch-val] (:dispatch-value (meta (i/effective-method multifn dispatch-val)))) |
Calculate the dispatch value that | (defn dispatch-value ;; 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 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))) |
Return a function that can be used to calculate dispatch values of given arg(s). | (defn dispatch-fn [multifn] (partial dispatch-value multifn)) |
Remove all primary methods, for all dispatch values (including the default value), for this | (defn remove-all-primary-methods [multifn] (reduce i/remove-primary-method multifn (keys (i/primary-methods multifn)))) |
With one arg, remove all auxiliary methods for a | (defn remove-all-aux-methods
([multifn]
(reduce remove-all-aux-methods multifn (keys (i/aux-methods multifn))))
([multifn qualifier]
(reduce
(fn [multifn dispatch-val]
(remove-all-aux-methods multifn qualifier dispatch-val))
multifn
(keys (get (i/aux-methods multifn) qualifier))))
([multifn qualifier dispatch-val]
(reduce
(fn [multifn f]
(i/remove-aux-method multifn qualifier dispatch-val f))
multifn
(get-in (i/aux-methods multifn) [qualifier dispatch-val])))) |
Remove all auxiliary methods for TODO -- consider renaming to | (defn remove-all-aux-methods-for-dispatch-val
[multifn dispatch-val]
(reduce
(fn [multifn qualifier]
(remove-all-aux-methods multifn qualifier dispatch-val))
multifn
(keys (i/aux-methods multifn)))) |
Remove an auxiliary method that was added by [[add-aux-method-with-unique-key]], if one exists. Returns | (defn remove-aux-method-with-unique-key
[multifn qualifier dispatch-val unique-key]
{:pre [(some? multifn)]}
(if-let [method (some
(fn [method]
(when (= (:methodical/unique-key (meta method)) unique-key)
method))
(aux-methods multifn qualifier dispatch-val))]
(i/remove-aux-method multifn qualifier dispatch-val method)
multifn)) |
Adds an auxiliary method with a | (defn add-aux-method-with-unique-key
[multifn qualifier dispatch-val f unique-key]
{:pre [(some? multifn)]}
(-> multifn
(remove-aux-method-with-unique-key qualifier dispatch-val unique-key)
(i/add-aux-method qualifier dispatch-val (fn-vary-meta f assoc :methodical/unique-key unique-key)))) |
Remove all primary and auxiliary methods, including default implementations. | (defn remove-all-methods [multifn] (-> multifn remove-all-primary-methods remove-all-aux-methods)) |
Add a method preference to | (defn add-preference
[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))) |
Prefer | (defn prefer-method
[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)))) |
(defn- remove-preference [preferences dispatch-value-x dispatch-value-y]
(let [updated-preferences (update preferences dispatch-value-x (fn [x-preferences]
(disj (set x-preferences) dispatch-value-y)))]
(if (empty? (get updated-preferences dispatch-value-x))
(dissoc updated-preferences dispatch-value-x)
updated-preferences))) | |
Return a copy of To destructively remove a dispatch value preference, use [[unprefer-method!]]. | (defn unprefer-method
[multifn dispatch-val-x dispatch-val-y]
{:pre [(some? multifn)]}
(let [preferences (i/prefers multifn)
updated-preferences (remove-preference preferences dispatch-val-x dispatch-val-y)]
(if (= preferences updated-preferences)
;; return multifn as is if nothing has changed.
multifn
(i/with-prefers multifn updated-preferences)))) |
Return a copy of To destructively remove all preferences, use [[remove-all-preferences!]]. | (defn remove-all-preferences
[multifn]
{:pre [(some? multifn)]}
(if (empty? (i/prefers multifn))
multifn
(i/with-prefers multifn {}))) |
When | (defn is-default-effective-method?
[multifn dispatch-val]
;; we need to make sure that a default method is present before calculating this stuff,
;; otherwise [[i/effective-method]] and [[default-effective-method]] will both return `nil`, giving us a false
;; positive here, even if there is an applicable non-default aux method. Also we need to make sure `{:dispatch-value
;; nil}` doesn't get confused with `nil` because there is no matching default method.
(let [multifn (i/add-primary-method multifn (i/default-dispatch-value multifn) (constantly nil))]
(= (:dispatch-value (meta (i/effective-method multifn dispatch-val)))
(:dispatch-value (meta (default-effective-method multifn)))))) |
When | (defn is-default-primary-method?
[multifn dispatch-val]
;; We need to make sure `{:dispatch-value nil}` for the effective primary method doesn't get confused with `nil`
;; if `(default-primary-method multifn)` doesn't return anything because there is no default method.
(let [multifn (i/add-primary-method multifn (i/default-dispatch-value multifn) (constantly nil))]
(= (:dispatch-value (meta (effective-primary-method multifn dispatch-val)))
(:dispatch-value (meta (default-primary-method multifn)))))) |
Low-level destructive operations | |
Build a docstring by taking the original user-supplied | (defn ^:no-doc docstring-with-describe-output-appended
(^String [varr]
(let [original-doc ((some-fn :original-doc :doc) (meta varr))
updated-value (var-get varr)]
(docstring-with-describe-output-appended original-doc updated-value)))
(^String [original-doc updated-value]
(str
(when (seq original-doc)
(str original-doc \newline \newline))
(describe/describe updated-value)))) |
Like [[clojure.core/alter-var-root]], but handles vars that are aliases of other vars, e.g. ones that have been imported via Potemkin [[potemkin/import-vars]]. | (defn alter-var-root+
[multifn-var f & args]
(let [{var-ns :ns, var-name :name} (meta multifn-var)
varr (if (and var-ns var-name)
(ns-resolve var-ns var-name)
multifn-var)
original-doc ((some-fn :original-doc :doc) (meta multifn-var))]
(apply alter-var-root varr f args)
(let [new-doc (docstring-with-describe-output-appended varr)]
(alter-meta! multifn-var assoc :original-doc original-doc, :doc new-doc))
multifn-var)) |
Destructive version of [[add-primary-method]]. Operates on a var defining a Methodical multifn. | (defn add-primary-method! [multifn-var dispatch-val f] (alter-var-root+ multifn-var i/add-primary-method dispatch-val f)) |
Destructive version of [[methodical.interface/remove-primary-method]]. Operates on a var defining a Methodical multifn. | (defn remove-primary-method! [multifn-var dispatch-val] (alter-var-root+ multifn-var i/remove-primary-method dispatch-val)) |
Destructive version of [[remove-all-primary-methods]]. Operates on a var defining a Methodical multifn. | (defn remove-all-primary-methods! [multifn-var] (alter-var-root+ multifn-var remove-all-primary-methods)) |
Destructive version of [[methodical.interface/add-aux-method]]. Operates on a var defining a Methodical multifn. | (defn add-aux-method! [multifn-var qualifier dispatch-val f] (alter-var-root+ multifn-var i/add-aux-method qualifier dispatch-val f)) |
Destructive version of [[methodical.interface/remove-aux-method]]. Operates on a var defining a Methodical multifn. | (defn remove-aux-method! [multifn-var qualifier dispatch-val f] (alter-var-root+ multifn-var i/remove-aux-method qualifier dispatch-val f)) |
Destructive version of [[remove-all-aux-methods]]. Operates on a var defining a Methodical multifn. | (defn remove-all-aux-methods! ([multifn-var] (alter-var-root+ multifn-var remove-all-aux-methods)) ([multifn-var qualifier] (alter-var-root+ multifn-var remove-all-aux-methods qualifier)) ([multifn-var qualifier dispatch-val] (alter-var-root+ multifn-var remove-all-aux-methods qualifier dispatch-val))) |
Destructive version of [[remove-all-aux-methods-for-dispatch-val]]. Operates on a var defining a Methodical multifn. | (defn remove-all-aux-methods-for-dispatch-val! [multifn-var dispatch-val] (alter-var-root+ multifn-var remove-all-aux-methods-for-dispatch-val dispatch-val)) |
Destructive version of [[add-aux-method-with-unique-key]]. Operates on a var defining a Methodical multifn. | (defn add-aux-method-with-unique-key! [multifn-var qualifier dispatch-val f unique-key] (alter-var-root+ multifn-var add-aux-method-with-unique-key qualifier dispatch-val f unique-key)) |
Destructive version of [[remove-aux-method-with-unique-key]]. Operates on a var defining a Methodical multifn. | (defn remove-aux-method-with-unique-key! [multifn-var qualifier dispatch-val unique-key] (alter-var-root+ multifn-var remove-aux-method-with-unique-key qualifier dispatch-val unique-key)) |
Destructive version of [[remove-all-methods]]. Operates on a var defining a Methodical multifn. | (defn remove-all-methods! [multifn-var] (alter-var-root+ multifn-var remove-all-methods)) |
Destructive version of [[methodical.interface/with-prefers]]. Operates on a var defining a Methodical multifn. | (defn with-prefers! [multifn-var new-prefs] (alter-var-root+ multifn-var i/with-prefers new-prefs)) |
Destructive version of [[prefer-method]]. Operates on a var defining a Methodical multifn. Note that vanilla Clojure [[clojure.core/prefer-method]] is actually itself destructive, so this function is
actually the Methodical equivalent of that function. | (defn prefer-method! [multifn-var dispatch-val-x dispatch-val-y] (alter-var-root+ multifn-var prefer-method dispatch-val-x dispatch-val-y)) |
Destructive version of [[unprefer-method]]. Operates on a var defining a Methodical multifn. | (defn unprefer-method! [multifn-var dispatch-val-x dispatch-val-y] (alter-var-root+ multifn-var unprefer-method dispatch-val-x dispatch-val-y)) |
Destructive version of [[remove-all-preferences]]. Operates on a var defining a Methodical multifn. | (defn remove-all-preferences! [multifn-var] (alter-var-root+ multifn-var remove-all-preferences)) |
(ns methodical.util.describe
(:require [clojure.datafy :as datafy]
[potemkin.types :as p.types])) | |
(p.types/defprotocol+ Describable
(describe ^String [this]
"Return a Markdown-formatted string description of a Methodical object, such as a multifn.")) | |
(extend-protocol Describable
nil
(describe [_this]
"nil")
Object
(describe [this]
(pr-str (datafy/datafy this)))) | |
Common dispatch function definitions. | (ns methodical.util.dispatch) |
Create a dispatch function this will dispatch on the value of ```clj
(dispatch-fn and ignore all other args. | (defn dispatch-on-first-arg
[dispatch-fn]
(fn dispatch-on-first-arg*
([a]
(dispatch-fn a))
([a _b]
(dispatch-fn a))
([a _b _c]
(dispatch-fn a))
([a _b _c _d]
(dispatch-fn a))
([a _b _c _d _e]
(dispatch-fn a))
([a _b _c _d _e & _more]
(dispatch-fn a)))) |
Create a dispatch function this will dispatch on the value of ```clj
[(dispatch-fn and ignore all other args. | (defn dispatch-on-first-two-args
([dispatch-fn]
(dispatch-on-first-two-args dispatch-fn dispatch-fn))
([dispatch-fn-a dispatch-fn-b]
(fn dispatch-on-first-two-args*
([a b]
[(dispatch-fn-a a) (dispatch-fn-b b)])
([a b _c]
(dispatch-on-first-two-args* a b))
([a b _c _d]
(dispatch-on-first-two-args* a b))
([a b _c _d _e]
(dispatch-on-first-two-args* a b))
([a b _c _d _e & _more]
(dispatch-on-first-two-args* a b))))) |
Create a dispatch function this will dispatch on the value of ```clj
[(dispatch-fn and ignore all other args. | (defn dispatch-on-first-three-args
([dispatch-fn]
(dispatch-on-first-three-args dispatch-fn dispatch-fn dispatch-fn))
([dispatch-fn-a dispatch-fn-b dispatch-fn-c]
(fn dispatch-on-first-three-args*
([a b c]
[(dispatch-fn-a a) (dispatch-fn-b b) (dispatch-fn-c c)])
([a b c _d]
(dispatch-on-first-three-args* a b c))
([a b c _d _e]
(dispatch-on-first-three-args* a b c))
([a b c _d _e & _more]
(dispatch-on-first-three-args* a b c))))) |
Create a dispatch function this will dispatch on the value of ```clj
[(dispatch-fn and ignore all other args. | (defn dispatch-on-first-four-args
([dispatch-fn]
(dispatch-on-first-four-args dispatch-fn dispatch-fn dispatch-fn dispatch-fn))
([dispatch-fn-a dispatch-fn-b dispatch-fn-c dispatch-fn-d]
(fn dispatch-on-first-four-args*
([a b c d]
[(dispatch-fn-a a) (dispatch-fn-b b) (dispatch-fn-c c) (dispatch-fn-d d)])
([a b c d _e]
(dispatch-on-first-four-args* a b c d))
([a b c d _e & _more]
(dispatch-on-first-four-args* a b c d))))) |
(ns methodical.util.trace
(:require [clojure.string :as str]
[methodical.interface :as i]
[methodical.util :as u]
[pretty.core :as pretty]
[puget.printer :as puget])) | |
(set! *warn-on-reflection* true) | |
Whether or not to print the trace in color. True by default, unless the env var | (def ^:dynamic *color*
(if-let [env-var-value (System/getenv "NO_COLOR")]
(complement (Boolean/parseBoolean env-var-value))
true)) |
Pretty-printer function to use for pretty printing forms in the trace. You can bind this to override the default pretty-printing functions (see below). | (def ^:dynamic *pprinter* nil) |
Wrap a String with | (defrecord Literal [s]) |
(def ^:private default-print-handlers
{Literal (fn [_printer literal]
[:text (:s literal)])}) | |
(defn- default-color-printer [x]
;; don't print in black. I can't see it
(puget/cprint x {:color-scheme {:nil nil}
:print-handlers default-print-handlers})) | |
(defn- default-boring-printer [x]
(puget/pprint x {:print-handlers default-print-handlers})) | |
Pretty print a form | (defn- pprint
[x]
((or *pprinter*
(if *color*
default-color-printer
default-boring-printer)) x)) |
Current depth of the trace. | (def ^:private ^:dynamic *trace-level* 0) |
Number of spaces to indent lines when printing stuff. | (def ^:private ^:dynamic *trace-indent* 0) |
(defn- trace-print-indent []
(doseq [_ (range *trace-indent*)]
(print " "))) | |
(defn- trace-println [& args]
(let [[first-line & more] (str/split-lines (str/trim (with-out-str (apply println args))))]
(println first-line)
(doseq [line more]
(trace-print-indent)
(println line)))) | |
(defn- describe-method [a-method]
(let [{:keys [qualifier dispatch-value]} (meta a-method)]
(->Literal (if qualifier
(format "#aux-method<%s %s>" (pr-str qualifier) (pr-str dispatch-value))
(format "#primary-method<%s>" (pr-str dispatch-value)))))) | |
(defn- describe [x]
(cond
(::description (meta x)) (::description (meta x))
(:dispatch-value (meta x)) (describe-method x)
(:methodical/combined-method? (meta x)) (->Literal "#combined-method")
(fn? x) (->Literal (pr-str x))
(instance? pretty.core.PrettyPrintable x) (pretty/pretty x)
:else x)) | |
(defn- trace-method [m]
(fn [& args]
(trace-print-indent)
(printf (format "%d: " *trace-level*))
(binding [*trace-indent* (+ *trace-indent* 3)]
(trace-println (with-out-str (pprint (map describe (cons m args))))))
(let [result (binding [*trace-level* (inc *trace-level*)
*trace-indent* (+ *trace-indent* 2)]
(apply m args))]
(trace-print-indent)
(printf "%d> " *trace-level*)
(binding [*trace-indent* (+ *trace-indent* 3)]
(trace-println (with-out-str (pprint (describe result)))))
result))) | |
(defn- trace-primary-method [primary-method]
(-> (trace-method 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)
(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 (u/fn-vary-meta aux-method assoc :qualifier qualifier)))]))) | |
Function version of [[trace]] macro. The only difference is this doesn't capture the form of | (defn trace*
[multifn & args]
(let [dispatch-value (apply u/dispatch-value multifn args)
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)
(u/fn-with-meta (meta multifn))
trace-method)]
(apply combined args))) |
Instrument a multimethod Method calls are printed with ```clj (trace/trace my-fn 1 {}) ;; -> 0: (my-fn 1 {}) 1: (#primary-method<:default> nil 1 {}) 1> {:x 1} 1: (#aux-method<:after [java.lang.Object :default]> 1 {:x 1}) 1> {:object? true, :x 1} 0> {:object? true, :x 1} ``` | (defmacro trace
[multifn & args]
`(trace* (vary-meta ~multifn assoc ::description '~multifn)
~@args)) |