more expressive tests for derive/underive

Signed-off-by: Stuart Halloway <stu@thinkrelevance.com>

1 files changed, 157 insertions, 104 deletions

diff --git a/test/clojure/test_clojure/multimethods.clj b/test/clojure/test_clojure/multimethods.clj
index 67747800..258562dc 100644
--- a/test/clojure/test_clojure/multimethods.clj
+++ b/test/clojure/test_clojure/multimethods.clj
@@ -9,7 +9,8 @@
 ; Author: Frantisek Sodomka, Robert Lachlan
 
 (ns clojure.test-clojure.multimethods
-  (:use clojure.test))
+  (:use clojure.test)
+  (:require [clojure.set :as set]))
 
 ; http://clojure.org/multimethods
 
@@ -20,107 +21,159 @@
 ; methods
 ; prefers
 
-
-;hierarchies for tests below, generated and literal
-(def h1 (reduce #(apply derive (cons %1 %2)) (make-hierarchy)
-                     [[:p1 :a1] [:p1 :a2] [:p2 :a2] [:c :p2] [:c :p1]]))
-(def h2 (reduce #(apply derive (cons %1 %2)) (make-hierarchy)
-                     [[:p1 :a1] [:p1 :a2] [:p2 :a2] [:c :p2]]))
-(def h3 (reduce #(apply derive (cons %1 %2)) (make-hierarchy)
-                     [[:p1 :a1] [:p2 :a2] [:c :p2] [:c :p1]]))
-(def h4 {:parents {:x8 #{:x6 :x7}, :x7 #{:x5}, :x6 #{:x5}, :x5 #{:x4},
-		   :x4 #{:x3 :x2}, :x3 #{:x1}, :x2 #{:x1}},
-	 :ancestors {:x8 #{:x4 :x5 :x6 :x7 :x3 :x2 :x1},
-		     :x7 #{:x4 :x5 :x3 :x2 :x1}, :x6 #{:x4 :x5 :x3 :x2 :x1},
-		     :x5 #{:x4 :x3 :x2 :x1}, :x4 #{:x3 :x2 :x1}, :x3 #{:x1},
-		     :x2 #{:x1}},
-	 :descendants {:x7 #{:x8}, :x6 #{:x8}, :x5 #{:x8 :x6 :x7},
-		       :x4 #{:x8 :x5 :x6 :x7}, :x3 #{:x8 :x4 :x5 :x6 :x7},
-		       :x2 #{:x8 :x4 :x5 :x6 :x7},
-		       :x1 #{:x8 :x4 :x5 :x6 :x7 :x3 :x2}}})
-(def h5 {:parents {:x2 #{:x1}, :x3 #{:x1}, :x4 #{:x3 :x2}, :x6 #{:x5},
-		   :x7 #{:x5}, :x8 #{:x6 :x7}},
-	 :ancestors {:x2 #{:x1}, :x3 #{:x1}, :x4 #{:x3 :x2 :x1}, :x6 #{:x5},
-		     :x7 #{:x5}, :x8 #{:x5 :x6 :x7}},
-	 :descendants {:x1 #{:x4 :x3 :x2}, :x2 #{:x4}, :x3 #{:x4},
-		       :x5 #{:x8 :x6 :x7}, :x7 #{:x8}, :x6 #{:x8}}})
-(def h6 {:parents {:a #{:b}}, :ancestors {:a #{:b}}, :descendants {:b #{:a}}})
-(def h7 {:parents {java.util.Map #{::maps}},
-	 :ancestors {java.util.Map #{::maps}},
-	 :descendants {::maps #{java.util.Map}}})
-
-
-; derive, [underive]
-(deftest derive-test
-  (is (= (derive h5 :x5 :x4) h4))
-  (is (= (derive (make-hierarchy) :a :b) h6))
-  (is (= (derive (make-hierarchy) java.util.Map ::maps) h7)))
-
-
-
-(deftest underive-test
-  (is (= (underive (make-hierarchy) :x :y) (make-hierarchy)))
-  (is (= (underive (derive (make-hierarchy) ::a ::b) ::a ::b)
-	 (make-hierarchy)))
-  (is (= (underive h1 :c :p1) h2))
-  (is (= (underive h1 :p1 :a2) h3))
-  (is (= (underive h4 :x5 :x4) h5))
-  (is (= (underive h5 :x5 :x4) h5))
-  (is (= (underive h4 :x8 :x1) h4))
-  (is (= (underive h4 :x9 :x4) h4))
-  (is (= (underive h4 :x5 :x10) h4))
-  (is (= (underive h7 java.util.Map ::maps) (make-hierarchy)))
-  (is (= (underive h7 java.util.HashMap ::maps) h7)))
-
-
-
-; isa?
-(deftest isa-test
-  (is (isa? h4 :x5 :x4))
-  (is (not (isa? h5 :x5 :x4)))
-  (is (isa? h4 :x8 :x1))
-  (is (not (isa? h5 :x8 :x1)))
-  (is (isa? java.util.HashMap java.util.Map))
-  (is (isa? h7 java.util.Map ::maps))
-  (is (not (isa? (make-hierarchy) java.util.Map ::a))))
-
-
-
-; parents, ancestors, descendants
-(deftest family-relation
-  (is (= (parents h4 :x1) nil))
-  (is (= (parents h4 :x4) #{:x2 :x3}))
-  (is (= (ancestors h5 :x1) nil))
-  (is (= (ancestors h4 :x4) #{:x1 :x2 :x3}))
-  (is (= (descendants h4 :y) nil))
-  (is (= (descendants h5 :x5) #{:x6 :x7 :x8})))
-
-; some simple global hierarchy tests
-
-(derive ::y1 ::y2)
-(derive ::y3 ::y4)
-
-(deftest global-isa1
-  (derive ::y4 ::y1)
-  (is (isa? ::y1 ::y2))
-  (not (isa? ::y3 ::y2)))
-
-
-(derive java.util.HashMap ::y4)
-
-(deftest global-isa2
-  (is (isa? ::y3 ::y2))
-  (is (isa? java.util.HashMap ::y2)))
-
-
-(deftest global-underive
-  (derive ::y4 ::y1)
-  (underive ::y4 ::y1)
-  (is (not (isa? ::y3 ::y1)))
-  (is (not (isa? java.util.HashMap ::y2))))
-
-
-; make-hierarchy
-(deftest make-hierarchy-test
-  (is (= {:parents {} :descendants {} :ancestors {}} (make-hierarchy))))
+(defn set-var-roots
+  [maplike]
+  (doseq [[var val] maplike]
+    (alter-var-root var (fn [_] val))))
+
+(defn with-var-roots*
+  "Temporarily set var roots, run block, then put original roots back."
+  [root-map f & args]
+  (let [originals (doall (map (fn [[var _]] [var @var]) root-map))]
+    (set-var-roots root-map)
+    (try
+     (apply f args)
+     (finally
+      (set-var-roots originals)))))
+
+(defmacro with-var-roots
+  [root-map & body]
+  `(with-var-roots* ~root-map (fn [] ~@body)))
+
+(defmacro for-all
+  [& args]
+  `(dorun (for ~@args)))
+
+(defn hierarchy-tags
+  "Return all tags in a derivation hierarchy"
+  [h]
+  (set/select
+   #(instance? clojure.lang.Named %)
+   (reduce into #{} (map keys (vals h)))))
+
+(defn transitive-closure
+  "Return all objects reachable by calling f starting with o,
+   not including o itself. f should return a collection."
+  [o f]
+  (loop [results #{}
+         more #{o}]
+    (let [new-objects (set/difference more results)]
+      (if (seq new-objects)
+        (recur (set/union results more) (reduce into #{} (map f new-objects)))
+        (disj results o)))))
+
+(defn tag-descendants
+  "Set of descedants which are tags (i.e. Named)."
+  [& args]
+  (set/select
+   #(instance? clojure.lang.Named %)
+   (or (apply descendants args) #{})))
+
+(defn assert-valid-hierarchy
+  [h]
+  (let [tags (hierarchy-tags h)]
+    (testing "ancestors are the transitive closure of parents"
+      (for-all [tag tags]
+        (is (= (transitive-closure tag #(parents h %))
+               (or (ancestors h tag) #{})))))
+    (testing "ancestors are transitive"
+      (for-all [tag tags]
+        (is (= (transitive-closure tag #(ancestors h %))
+               (or (ancestors h tag) #{})))))
+    (testing "tag descendants are transitive"
+      (for-all [tag tags]
+        (is (= (transitive-closure tag #(tag-descendants h %))
+               (or (tag-descendants h tag) #{})))))
+    (testing "a tag isa? all of its parents"
+      (for-all [tag tags
+               :let [parents (parents h tag)]
+               parent parents]
+        (is (isa? h tag parent))))
+    (testing "a tag isa? all of its ancestors"
+      (for-all [tag tags
+               :let [ancestors (ancestors h tag)]
+               ancestor ancestors]
+        (is (isa? h tag ancestor))))
+    (testing "all my descendants have me as an ancestor"
+      (for-all [tag tags
+               :let [descendants (descendants h tag)]
+                descendant descendants]
+        (is (isa? h descendant tag))))
+    (testing "there are no cycles in parents"
+      (for-all [tag tags]
+        (is (not (contains? (transitive-closure tag #(parents h %)) tag)))))
+    (testing "there are no cycles in descendants"
+      (for-all [tag tags]
+        (is (not (contains? (descendants h tag) tag)))))))
+
+(def family
+  (reduce #(apply derive (cons %1 %2)) (make-hierarchy)
+          [[::parent-1 ::ancestor-1]
+           [::parent-1 ::ancestor-2]
+           [::parent-2 ::ancestor-2]
+           [::child ::parent-2]
+           [::child ::parent-1]]))
+
+(deftest cycles-are-forbidden
+  (testing "a tag cannot be its own parent"
+    (is (thrown-with-msg? Throwable #"\(not= tag parent\)"
+          (derive family ::child ::child))))
+  (testing "a tag cannot be its own ancestor"
+    (is (thrown-with-msg? Throwable #"Cyclic derivation: :clojure.test-clojure.multimethods/child has :clojure.test-clojure.multimethods/ancestor-1 as ancestor"
+          (derive family ::ancestor-1 ::child)))))
+
+(deftest using-diamond-inheritance
+  (let [diamond (reduce #(apply derive (cons %1 %2)) (make-hierarchy)
+                        [[::mammal ::animal]
+                         [::bird ::animal]
+                         [::griffin ::mammal]
+                         [::griffin ::bird]])
+        bird-no-more (underive diamond ::griffin ::bird)]
+    (assert-valid-hierarchy diamond)
+    (assert-valid-hierarchy bird-no-more)
+    (testing "a griffin is a mammal, indirectly through mammal and bird"
+      (is (isa? diamond ::griffin ::animal)))
+    (testing "a griffin is a bird"
+      (is (isa? diamond ::griffin ::bird)))
+    (testing "after underive, griffin is no longer a bird"
+      (is (not (isa? bird-no-more ::griffin ::bird))))
+    (testing "but it is still an animal, via mammal"
+      (is (isa? bird-no-more ::griffin ::animal)))))
+
+(deftest derivation-world-bridges-to-java-inheritance
+  (let [h (derive (make-hierarchy) java.util.Map ::map)]
+    (testing "a Java class can be isa? a tag"
+      (is (isa? h java.util.Map ::map)))
+    (testing "if a Java class isa? a tag, so are its subclasses..."
+      (is (isa? h java.util.HashMap ::map)))
+    (testing "...but not its superclasses!"
+      (is (not (isa? h java.util.Collection ::map))))))
+
+(deftest global-hierarchy-test
+  (with-var-roots {#'clojure.core/global-hierarchy (make-hierarchy)}
+    (assert-valid-hierarchy @#'clojure.core/global-hierarchy)
+    (testing "when you add some derivations..."
+      (derive ::lion ::cat)
+      (derive ::manx ::cat)
+      (assert-valid-hierarchy @#'clojure.core/global-hierarchy))
+    (testing "...isa? sees the derivations"
+      (is (isa? ::lion ::cat))
+      (is (not (isa? ::cat ::lion))))
+    (testing "... you can traverse the derivations"
+      (is (= #{::manx ::lion} (descendants ::cat)))
+      (is (= #{::cat} (parents ::manx)))
+      (is (= #{::cat} (ancestors ::manx))))
+    (testing "then, remove a derivation..."
+      (underive ::manx ::cat))
+    (testing "... traversals update accordingly"
+      (is (= #{::lion} (descendants ::cat)))
+      (is (nil? (parents ::manx)))
+      (is (nil? (ancestors ::manx))))))
+
+#_(defmacro for-all
+  "Better than the actual for-all, if only it worked."
+  [& args]
+  `(reduce
+    #(and %1 %2)
+    (map true? (for ~@args))))