isa-based multimethods, a la carte hierarchies

4 files changed, 234 insertions, 35 deletions

diff --git a/src/clojure/boot.clj b/src/clojure/boot.clj
index 04e7e61a..3b6d70bb 100644
--- a/src/clojure/boot.clj
+++ b/src/clojure/boot.clj
@@ -925,16 +925,20 @@
 (defmacro defmethod
   "Creates and installs a new method of multimethod associated with dispatch-value. "
   [multifn dispatch-val & fn-tail]
-  `(let [pvar# (var ~multifn)]
-     (. pvar# (commuteRoot (fn [#^clojure.lang.MultiFn mf#] 
-                             (. mf# (assoc ~dispatch-val (fn ~@fn-tail))))))))
+  `(. ~multifn addMethod ~dispatch-val (fn ~@fn-tail)))
+
+;  `(let [pvar# (var ~multifn)]
+;     (. pvar# (commuteRoot (fn [#^clojure.lang.MultiFn mf#] 
+;                             (. mf# (assoc ~dispatch-val (fn ~@fn-tail))))))))
 
 (defmacro remove-method
   "Removes the method of multimethod associated	with dispatch-value."
  [multifn dispatch-val]
-  `(let [pvar# (var ~multifn)]
-      (. pvar# (commuteRoot (fn [#^clojure.lang.MultiFn mf#] 
-                              (. mf# (dissoc ~dispatch-val)))))))
+ `(. ~multifn removeMethod ~dispatch-val))
+
+;  `(let [pvar# (var ~multifn)]
+;      (. pvar# (commuteRoot (fn [#^clojure.lang.MultiFn mf#] 
+;                              (. mf# (dissoc ~dispatch-val)))))))
 
 ;;;;;;;;; var stuff      
 
@@ -2720,4 +2724,141 @@ not-every? (comp not every?))
 
 (defn class?
   "Returns true if x is an instance of Class"
-  [x] (instance? Class x))
\ No newline at end of file
+  [x] (instance? Class x))
+
+(defn alter-var-root
+  "Atomically alters the root binding of var v by applying f to its
+  current value plus any args"
+  [#^clojure.lang.Var v f & args] (.alterRoot v f args))
+
+(defn make-hierarchy 
+  "Creates a hierarchy object for use with derive, isa? etc."
+  [] {:parents {} :descendants {} :ancestors {}})
+
+(def #^{:private true}
+     global-hierarchy (make-hierarchy))
+
+(defn not-empty 
+  "If coll is empty, returns nil, else coll"
+  [coll] (when (seq coll) coll))
+
+(defn bases
+  "Returns the immediate superclass and direct interfaces of c, if any"
+  [#^Class c]
+  (let [i (.getInterfaces c)
+        s (.getSuperclass c)]
+    (not-empty
+     (if s (cons s i) i))))
+
+(defn supers 
+  "Returns the immediate and indirect superclasses and interfaces of c, if any"
+  [#^Class class]
+  (loop [ret #{} c class]
+    (if c
+      (recur (into ret (bases c)) (.getSuperclass c))
+      (not-empty ret))))
+
+(defn isa?
+  "Returns true if child is directly or indirectly derived from
+  parent, 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 defaults to the global
+  hierarchy"
+  ([child parent] (isa? global-hierarchy child parent))
+  ([h child parent]
+   (or (= child parent)
+       (and (class? parent) (class? child) 
+            (. #^Class parent isAssignableFrom child))
+       (contains? ((:ancestors h) child) parent)
+       (and (class child) (some #(contains? ((:ancestors h) %) parent) (supers child)))
+       (and (vector? parent) (vector? child)
+            (= (count parent) (count child))
+            (loop [ret true i 0]
+              (if (= i (count parent))
+                ret
+                (recur (and (isa? (child i) (parent i)) ret) (inc i))))))))
+
+(defn parents
+  "Returns the immediate 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
+  defaults to the global hierarchy"
+  ([tag] (parents global-hierarchy tag))
+  ([h tag] (not-empty
+            (let [tp (get (:parents h) tag)]
+              (if (class? tag)
+                (into (set (bases tag)) tp) 
+                tp)))))
+
+(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
+  defaults to the global hierarchy"
+  ([tag] (ancestors global-hierarchy tag))
+  ([h tag] (not-empty
+            (let [ta (get (:ancestors h) tag)]
+              (if (class? tag)
+                (into (set (supers tag)) ta) 
+                ta)))))
+
+(defn descendants
+  "Returns the immediate and indirect children 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
+  defaults to the global hierarchy" 
+  ([tag] (descendants global-hierarchy tag))
+  ([h tag] (if (class? tag)
+             (throw (java.lang.UnsupportedOperationException. "Can't get descendants of classes"))
+             (not-empty (get (:descendants h) tag)))))
+
+(defn derive
+  "Establishes a parent/child relationship between parent and
+  tag. Parent must be a namespace-qualified symbol or keyword and
+  child can be either a namespace-qualified symbol or keyword or a
+  class. 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 derive tag parent) nil)
+  ([h tag parent]
+   (assert (not= tag parent))
+   (assert (or (class? tag) (and (instance? clojure.lang.Named tag) (namespace tag))))
+   (assert (instance? clojure.lang.Named parent))
+   (assert (namespace parent))
+
+   (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))))]
+     (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)}))))
+
+(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)
+  ([h tag parent]
+   (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 disj (get targets k) (cons target (targets target)))))
+               m (cons source (sources source))))]
+     (when (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)}))))
diff --git a/src/jvm/clojure/lang/LispReader.java b/src/jvm/clojure/lang/LispReader.java
index 17dd8479..cc11603a 100644
--- a/src/jvm/clojure/lang/LispReader.java
+++ b/src/jvm/clojure/lang/LispReader.java
@@ -40,7 +40,7 @@ static Symbol DEREF = Symbol.create("clojure", "deref");
 static IFn[] macros = new IFn[256];

 static IFn[] dispatchMacros = new IFn[256];

 //static Pattern symbolPat = Pattern.compile("[:]?([\\D&&[^:/]][^:/]*/)?[\\D&&[^:/]][^:/]*");

-static Pattern symbolPat = Pattern.compile("[:]?([\\D&&[^:/]].*/)?([\\D&&[^:/]][^/]*)");

+static Pattern symbolPat = Pattern.compile("[:]?([\\D&&[^/]].*/)?([\\D&&[^/]][^/]*)");

 //static Pattern varPat = Pattern.compile("([\\D&&[^:\\.]][^:\\.]*):([\\D&&[^:\\.]][^:\\.]*)");

 //static Pattern intPat = Pattern.compile("[-+]?[0-9]+\\.?");

 static Pattern intPat =

@@ -275,8 +275,13 @@ private static Object matchSymbol(String s){
 		String name = m.group(2);

 		if(ns != null && ns.endsWith(":/")

 		   || name.endsWith(":")

-		   || s.contains("::"))

+		   || s.indexOf("::", 1) != -1)

 			return null;

+		if(s.startsWith("::"))

+			{

+			//auto-resolving keyword

+			return Keyword.intern(Compiler.resolveSymbol(Symbol.intern(s.substring(2))));

+			}

 		boolean isKeyword = s.charAt(0) == ':';

 		Symbol sym = Symbol.intern(s.substring(isKeyword ? 1 : 0));

 		if(isKeyword)

diff --git a/src/jvm/clojure/lang/MultiFn.java b/src/jvm/clojure/lang/MultiFn.java
index f5c09c12..e956b761 100644
--- a/src/jvm/clojure/lang/MultiFn.java
+++ b/src/jvm/clojure/lang/MultiFn.java
@@ -12,48 +12,93 @@
 
 package clojure.lang;
 
+import java.util.Map;
+
 public class MultiFn extends AFn{
 final public IFn dispatchFn;
 final public Object defaultDispatchVal;
-final public IPersistentMap methodTable;
+IPersistentMap methodTable;
+IPersistentMap methodCache;
+Object cachedHierarchy;
+
+static final Var assoc = RT.var("clojure", "assoc");
+static final Var dissoc = RT.var("clojure", "dissoc");
+static final Var isa = RT.var("clojure", "isa?");
+static final Var hierarchy = RT.var("clojure", "global-hierarchy");
 
-public MultiFn(IFn dispatchFn, Object defaultDispatchVal){
+public MultiFn(IFn dispatchFn, Object defaultDispatchVal) throws Exception{
 	this.dispatchFn = dispatchFn;
 	this.defaultDispatchVal = defaultDispatchVal;
 	this.methodTable = PersistentHashMap.EMPTY;
+	this.methodCache = methodTable;
+	cachedHierarchy = null;
 }
 
-public MultiFn assoc(Object dispatchVal, IFn method){
-	return new MultiFn(meta(), dispatchFn, defaultDispatchVal, methodTable.assoc(dispatchVal, method));
-}
-
-
-public MultiFn dissoc(Object dispatchVal) throws Exception{
-	return new MultiFn(meta(), dispatchFn,  defaultDispatchVal, methodTable.without(dispatchVal));
+synchronized public MultiFn addMethod(Object dispatchVal, IFn method) throws Exception{
+	methodTable = methodTable.assoc(dispatchVal, method);
+	resetCache();
+	return this;
 }
 
-public Obj withMeta(IPersistentMap meta){
-	if(meta == meta())
-		return this;
-	return new MultiFn(meta, dispatchFn, defaultDispatchVal, methodTable);
+synchronized public MultiFn removeMethod(Object dispatchVal) throws Exception{
+	methodTable = methodTable.without(dispatchVal);
+	resetCache();
+	return this;
 }
 
-private MultiFn(IPersistentMap meta, IFn dispatchFn, Object defaultDispatchVal, IPersistentMap dispatchTable){
-	super(meta);
-	this.dispatchFn = dispatchFn;
-	this.defaultDispatchVal = defaultDispatchVal;
-	this.methodTable = dispatchTable;
+private IPersistentMap resetCache(){
+	methodCache = methodTable;
+	cachedHierarchy = hierarchy.get();
+	return methodCache;
 }
 
-private IFn getFn(Object dispatchVal) throws Exception{
-	IFn targetFn = (IFn) methodTable.valAt(dispatchVal);
-	if(targetFn == null)
-	    targetFn = (IFn) methodTable.valAt(defaultDispatchVal);
+synchronized private IFn getFn(Object dispatchVal) throws Exception{
+	if(cachedHierarchy != hierarchy.get())
+		resetCache();
+	IFn targetFn = (IFn) methodCache.valAt(dispatchVal);
+	if(targetFn != null)
+		return targetFn;
+	targetFn = findAndCacheBestMethod(dispatchVal);
+	if(targetFn != null)
+		return targetFn;
+	targetFn = (IFn) methodTable.valAt(defaultDispatchVal);
 	if(targetFn == null)
 		throw new IllegalArgumentException(String.format("No method for dispatch value: %s", dispatchVal));
 	return targetFn;
 }
 
+private IFn findAndCacheBestMethod(Object dispatchVal) throws Exception{
+	Map.Entry bestEntry = null;
+	for(Object o : methodTable)
+		{
+		Map.Entry e = (Map.Entry) o;
+		if(RT.booleanCast(isa.invoke(dispatchVal, e.getKey())))
+			{
+			if(bestEntry == null || RT.booleanCast(isa.invoke(e.getKey(), bestEntry.getKey())))
+				bestEntry = e;
+			if(!RT.booleanCast(isa.invoke(bestEntry.getKey(), e.getKey())))
+				throw new IllegalArgumentException(
+						String.format("Multiple methods match dispatch value: %s -> %s and %s",
+						              dispatchVal, e.getKey(), bestEntry.getKey()));
+			}
+		}
+	if(bestEntry == null)
+		throw new IllegalArgumentException(String.format("No method for dispatch value: %s", dispatchVal));
+
+	//ensure basis has stayed stable throughout, else redo
+	if(cachedHierarchy == hierarchy.get())
+		{
+		//place in cache
+		methodCache = methodCache.assoc(dispatchVal, bestEntry.getValue());
+		return (IFn) bestEntry.getValue();
+		}
+	else
+		{
+		resetCache();
+		return findAndCacheBestMethod(dispatchVal);
+		}
+}
+
 public Object invoke() throws Exception{
 	return getFn(dispatchFn.invoke()).invoke();
 }
diff --git a/src/jvm/clojure/lang/Var.java b/src/jvm/clojure/lang/Var.java
index f7d42c22..fe6b8b9d 100644
--- a/src/jvm/clojure/lang/Var.java
+++ b/src/jvm/clojure/lang/Var.java
@@ -131,7 +131,7 @@ final public Object get(){
 
 public void setValidator(IFn vf){
 	if(isBound())
-		validate(vf,getRoot());
+		validate(vf, getRoot());
 	validator = vf;
 }
 
@@ -145,7 +145,8 @@ public Object alter(IFn fn, ISeq args) throws Exception{
 }
 
 void validate(IFn vf, Object val){
-	try{
+	try
+		{
 		if(vf != null)
 			vf.invoke(val);
 		}
@@ -156,7 +157,7 @@ void validate(IFn vf, Object val){
 }
 
 public Object set(Object val){
-	validate(getValidator(),val);
+	validate(getValidator(), val);
 	Box b = getThreadBinding();
 	if(b != null)
 		return (b.val = val);
@@ -227,8 +228,15 @@ synchronized public void unbindRoot(){
 
 synchronized public void commuteRoot(IFn fn) throws Exception{
 	Object newRoot = fn.invoke(root);
-	validate(getValidator(),newRoot);
+	validate(getValidator(), newRoot);
+	this.root = newRoot;
+}
+
+synchronized public Object alterRoot(IFn fn, ISeq args) throws Exception{
+	Object newRoot = fn.applyTo(RT.cons(root, args));
+	validate(getValidator(), newRoot);
 	this.root = newRoot;
+	return newRoot;
 }
 
 public static void pushThreadBindings(Associative bindings){