Allow multimethods to have own hierarchies This patch allows multimethods to use different hierarchies, than the global hierarchy for use with isa?. Currently only the global hierarchy is possible. The patch extends the MultiFn class to accept also a Var pointing to a hierarchy. The rationale is, that otherwise the multimethod cannot be extended with derivation after it's definition. Hence it cannot receive the hierarchy directly. To promote that every hierarchy must be a Var, derive and underive are modified to act on vars instead of the hierarchies directly. Furthermore the convenience macros defhierarchy and defhierarchy- are provided, which define new hierarchies with optional docstring support and automatic initialisation with make-hierarchy. diff --git a/src/clj/clojure/core.clj b/src/clj/clojure/core.clj --- a/src/clj/clojure/core.clj +++ b/src/clj/clojure/core.clj @@ -994,6 +994,8 @@ ([x form & more] `(-> (-> ~x ~form) ~@more))) ;;multimethods +(def global-hierarchy) + (defmacro defmulti "Creates a new multimethod with the associated dispatch function. If default-dispatch-val is supplied it becomes the default dispatch @@ -1002,11 +1004,12 @@ [mm-name dispatch-fn & options] (when (= (count options) 1) (throw (Exception. "The syntax for defmulti has changed. Example: (defmulti name dispatch-fn :default dispatch-value)"))) - (let [options (apply hash-map options) - default (get options :default :default)] + (let [options (apply hash-map options) + default (get options :default :default) + hierarchy (get options :hierarchy `global-hierarchy)] `(def ~(with-meta mm-name (assoc (meta mm-name) :tag 'clojure.lang.MultiFn)) - (new clojure.lang.MultiFn ~dispatch-fn ~default)))) + (new clojure.lang.MultiFn ~dispatch-fn ~default (var ~hierarchy))))) (defmacro defmethod "Creates and installs a new method of multimethod associated with dispatch-value. " @@ -3069,8 +3072,25 @@ "Creates a hierarchy object for use with derive, isa? etc." [] {:parents {} :descendants {} :ancestors {}}) -(def #^{:private true} - global-hierarchy (make-hierarchy)) +(defmacro defhierarchy + "Defines a new hierarchy for use with derive, isa? etc." + ([hname] `(defhierarchy ~hname nil)) + ([hname docstring] + (let [meta-info (if docstring + (assoc (meta hname) :doc docstring) + (meta hname))] + `(def ~(with-meta hname meta-info) + (make-hierarchy))))) + +(defmacro defhierarchy- + "Defines a new hierarchy for use with derive, isa? etc., but unlike + defhierarchy the resulting hierarchy is private to the defining + namespace." + [hname & args] + `(defhierarchy ~(with-meta hname (assoc (meta hname) :private true)) + ~@args)) + +(defhierarchy- global-hierarchy) (defn not-empty "If coll is empty, returns nil, else coll" @@ -3125,7 +3145,7 @@ (into (set (bases tag)) tp) tp))))) -(defn ancestors +(defn ancestors "Returns the immediate and indirect parents of tag, either via a Java type inheritance relationship or a relationship established via derive. h must be a hierarchy obtained from make-hierarchy, if not supplied @@ -3158,51 +3178,63 @@ (assert (namespace parent)) (assert (or (class? tag) (and (instance? clojure.lang.Named tag) (namespace tag)))) - (alter-var-root #'global-hierarchy derive tag parent) nil) + (derive #'global-hierarchy tag parent)) ([h tag parent] (assert (not= tag parent)) (assert (or (class? tag) (instance? clojure.lang.Named tag))) (assert (instance? clojure.lang.Named parent)) - (let [tp (:parents h) - td (:descendants h) - ta (:ancestors h) + (let [tp (:parents @h) + td (:descendants @h) + ta (:ancestors @h) tf (fn [m source sources target targets] (reduce (fn [ret k] (assoc ret k (reduce conj (get targets k #{}) (cons target (targets target))))) m (cons source (sources source))))] - (or - (when-not (contains? (tp tag) parent) - (when (contains? (ta tag) parent) - (throw (Exception. (print-str tag "already has" parent "as ancestor")))) - (when (contains? (ta parent) tag) - (throw (Exception. (print-str "Cyclic derivation:" parent "has" tag "as ancestor")))) - {:parents (assoc (:parents h) tag (conj (get tp tag #{}) parent)) - :ancestors (tf (:ancestors h) tag td parent ta) - :descendants (tf (:descendants h) parent ta tag td)}) - h)))) + (alter-var-root h + (fn [h] + (or + (when-not (contains? (tp tag) parent) + (when (contains? (ta tag) parent) + (throw (Exception. (print-str tag + "already has" + parent + "as ancestor")))) + (when (contains? (ta parent) tag) + (throw (Exception. (print-str "Cyclic derivation:" + parent "has" + tag "as ancestor")))) + {:parents (assoc (:parents h) + tag (conj (get tp tag #{}) parent)) + :ancestors (tf (:ancestors h) tag td parent ta) + :descendants (tf (:descendants h) parent ta tag td)}) + h)))) + nil)) -(defn underive +(defn underive "Removes a parent/child relationship between parent and tag. h must be a hierarchy obtained from make-hierarchy, if not supplied defaults to, and modifies, the global hierarchy." - ([tag parent] (alter-var-root #'global-hierarchy underive tag parent) nil) + ([tag parent] (underive #'global-hierarchy tag parent)) ([h tag parent] - (let [tp (:parents h) - td (:descendants h) - ta (:ancestors h) + (let [tp (:parents @h) + td (:descendants @h) + ta (:ancestors @h) tf (fn [m source sources target targets] (reduce (fn [ret k] - (assoc ret k + (assoc ret k (reduce disj (get targets k) (cons target (targets target))))) m (cons source (sources source))))] - (if (contains? (tp tag) parent) - {:parent (assoc (:parents h) tag (disj (get tp tag) parent)) - :ancestors (tf (:ancestors h) tag td parent ta) - :descendants (tf (:descendants h) parent ta tag td)} - h)))) + (alter-var-root h + (fn [h] + (if (contains? (tp tag) parent) + {:parent (assoc (:parents h) tag (disj (get tp tag) parent)) + :ancestors (tf (:ancestors h) tag td parent ta) + :descendants (tf (:descendants h) parent ta tag td)} + h)))) + nil)) (defn distinct? diff --git a/src/jvm/clojure/lang/MultiFn.java b/src/jvm/clojure/lang/MultiFn.java --- a/src/jvm/clojure/lang/MultiFn.java +++ b/src/jvm/clojure/lang/MultiFn.java @@ -18,6 +18,7 @@ public class MultiFn extends AFn{ final public IFn dispatchFn; final public Object defaultDispatchVal; +final public Var hierarchy; IPersistentMap methodTable; IPersistentMap preferTable; IPersistentMap methodCache; @@ -27,11 +28,11 @@ static final Var dissoc = RT.var("clojure.core", "dissoc"); static final Var isa = RT.var("clojure.core", "isa?"); static final Var parents = RT.var("clojure.core", "parents"); -static final Var hierarchy = RT.var("clojure.core", "global-hierarchy"); -public MultiFn(IFn dispatchFn, Object defaultDispatchVal) throws Exception{ +public MultiFn(IFn dispatchFn, Object defaultDispatchVal, Var hierarchy) throws Exception{ this.dispatchFn = dispatchFn; this.defaultDispatchVal = defaultDispatchVal; + this.hierarchy = hierarchy; this.methodTable = PersistentHashMap.EMPTY; this.methodCache = methodTable; this.preferTable = PersistentHashMap.EMPTY; @@ -80,7 +81,7 @@ } private boolean isA(Object x, Object y) throws Exception{ - return RT.booleanCast(isa.invoke(x, y)); + return RT.booleanCast(isa.invoke(hierarchy.get(), x, y)); } private boolean dominates(Object x, Object y) throws Exception{