|
rlm@10
|
1 ; Copyright (c) Rich Hickey. All rights reserved.
|
|
rlm@10
|
2 ; The use and distribution terms for this software are covered by the
|
|
rlm@10
|
3 ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
|
|
rlm@10
|
4 ; which can be found in the file epl-v10.html at the root of this distribution.
|
|
rlm@10
|
5 ; By using this software in any fashion, you are agreeing to be bound by
|
|
rlm@10
|
6 ; the terms of this license.
|
|
rlm@10
|
7 ; You must not remove this notice, or any other, from this software.
|
|
rlm@10
|
8
|
|
rlm@10
|
9 ; Author: Frantisek Sodomka, Robert Lachlan
|
|
rlm@10
|
10
|
|
rlm@10
|
11 (ns clojure.test-clojure.multimethods
|
|
rlm@10
|
12 (:use clojure.test [clojure.test-clojure.helpers :only (with-var-roots)])
|
|
rlm@10
|
13 (:require [clojure.set :as set]))
|
|
rlm@10
|
14
|
|
rlm@10
|
15 ; http://clojure.org/multimethods
|
|
rlm@10
|
16
|
|
rlm@10
|
17 ; defmulti
|
|
rlm@10
|
18 ; defmethod
|
|
rlm@10
|
19 ; remove-method
|
|
rlm@10
|
20 ; prefer-method
|
|
rlm@10
|
21 ; methods
|
|
rlm@10
|
22 ; prefers
|
|
rlm@10
|
23
|
|
rlm@10
|
24 (defmacro for-all
|
|
rlm@10
|
25 [& args]
|
|
rlm@10
|
26 `(dorun (for ~@args)))
|
|
rlm@10
|
27
|
|
rlm@10
|
28 (defn hierarchy-tags
|
|
rlm@10
|
29 "Return all tags in a derivation hierarchy"
|
|
rlm@10
|
30 [h]
|
|
rlm@10
|
31 (set/select
|
|
rlm@10
|
32 #(instance? clojure.lang.Named %)
|
|
rlm@10
|
33 (reduce into #{} (map keys (vals h)))))
|
|
rlm@10
|
34
|
|
rlm@10
|
35 (defn transitive-closure
|
|
rlm@10
|
36 "Return all objects reachable by calling f starting with o,
|
|
rlm@10
|
37 not including o itself. f should return a collection."
|
|
rlm@10
|
38 [o f]
|
|
rlm@10
|
39 (loop [results #{}
|
|
rlm@10
|
40 more #{o}]
|
|
rlm@10
|
41 (let [new-objects (set/difference more results)]
|
|
rlm@10
|
42 (if (seq new-objects)
|
|
rlm@10
|
43 (recur (set/union results more) (reduce into #{} (map f new-objects)))
|
|
rlm@10
|
44 (disj results o)))))
|
|
rlm@10
|
45
|
|
rlm@10
|
46 (defn tag-descendants
|
|
rlm@10
|
47 "Set of descedants which are tags (i.e. Named)."
|
|
rlm@10
|
48 [& args]
|
|
rlm@10
|
49 (set/select
|
|
rlm@10
|
50 #(instance? clojure.lang.Named %)
|
|
rlm@10
|
51 (or (apply descendants args) #{})))
|
|
rlm@10
|
52
|
|
rlm@10
|
53 (defn assert-valid-hierarchy
|
|
rlm@10
|
54 [h]
|
|
rlm@10
|
55 (let [tags (hierarchy-tags h)]
|
|
rlm@10
|
56 (testing "ancestors are the transitive closure of parents"
|
|
rlm@10
|
57 (for-all [tag tags]
|
|
rlm@10
|
58 (is (= (transitive-closure tag #(parents h %))
|
|
rlm@10
|
59 (or (ancestors h tag) #{})))))
|
|
rlm@10
|
60 (testing "ancestors are transitive"
|
|
rlm@10
|
61 (for-all [tag tags]
|
|
rlm@10
|
62 (is (= (transitive-closure tag #(ancestors h %))
|
|
rlm@10
|
63 (or (ancestors h tag) #{})))))
|
|
rlm@10
|
64 (testing "tag descendants are transitive"
|
|
rlm@10
|
65 (for-all [tag tags]
|
|
rlm@10
|
66 (is (= (transitive-closure tag #(tag-descendants h %))
|
|
rlm@10
|
67 (or (tag-descendants h tag) #{})))))
|
|
rlm@10
|
68 (testing "a tag isa? all of its parents"
|
|
rlm@10
|
69 (for-all [tag tags
|
|
rlm@10
|
70 :let [parents (parents h tag)]
|
|
rlm@10
|
71 parent parents]
|
|
rlm@10
|
72 (is (isa? h tag parent))))
|
|
rlm@10
|
73 (testing "a tag isa? all of its ancestors"
|
|
rlm@10
|
74 (for-all [tag tags
|
|
rlm@10
|
75 :let [ancestors (ancestors h tag)]
|
|
rlm@10
|
76 ancestor ancestors]
|
|
rlm@10
|
77 (is (isa? h tag ancestor))))
|
|
rlm@10
|
78 (testing "all my descendants have me as an ancestor"
|
|
rlm@10
|
79 (for-all [tag tags
|
|
rlm@10
|
80 :let [descendants (descendants h tag)]
|
|
rlm@10
|
81 descendant descendants]
|
|
rlm@10
|
82 (is (isa? h descendant tag))))
|
|
rlm@10
|
83 (testing "there are no cycles in parents"
|
|
rlm@10
|
84 (for-all [tag tags]
|
|
rlm@10
|
85 (is (not (contains? (transitive-closure tag #(parents h %)) tag)))))
|
|
rlm@10
|
86 (testing "there are no cycles in descendants"
|
|
rlm@10
|
87 (for-all [tag tags]
|
|
rlm@10
|
88 (is (not (contains? (descendants h tag) tag)))))))
|
|
rlm@10
|
89
|
|
rlm@10
|
90 (def family
|
|
rlm@10
|
91 (reduce #(apply derive (cons %1 %2)) (make-hierarchy)
|
|
rlm@10
|
92 [[::parent-1 ::ancestor-1]
|
|
rlm@10
|
93 [::parent-1 ::ancestor-2]
|
|
rlm@10
|
94 [::parent-2 ::ancestor-2]
|
|
rlm@10
|
95 [::child ::parent-2]
|
|
rlm@10
|
96 [::child ::parent-1]]))
|
|
rlm@10
|
97
|
|
rlm@10
|
98 (deftest cycles-are-forbidden
|
|
rlm@10
|
99 (testing "a tag cannot be its own parent"
|
|
rlm@10
|
100 (is (thrown-with-msg? Throwable #"\(not= tag parent\)"
|
|
rlm@10
|
101 (derive family ::child ::child))))
|
|
rlm@10
|
102 (testing "a tag cannot be its own ancestor"
|
|
rlm@10
|
103 (is (thrown-with-msg? Throwable #"Cyclic derivation: :clojure.test-clojure.multimethods/child has :clojure.test-clojure.multimethods/ancestor-1 as ancestor"
|
|
rlm@10
|
104 (derive family ::ancestor-1 ::child)))))
|
|
rlm@10
|
105
|
|
rlm@10
|
106 (deftest using-diamond-inheritance
|
|
rlm@10
|
107 (let [diamond (reduce #(apply derive (cons %1 %2)) (make-hierarchy)
|
|
rlm@10
|
108 [[::mammal ::animal]
|
|
rlm@10
|
109 [::bird ::animal]
|
|
rlm@10
|
110 [::griffin ::mammal]
|
|
rlm@10
|
111 [::griffin ::bird]])
|
|
rlm@10
|
112 bird-no-more (underive diamond ::griffin ::bird)]
|
|
rlm@10
|
113 (assert-valid-hierarchy diamond)
|
|
rlm@10
|
114 (assert-valid-hierarchy bird-no-more)
|
|
rlm@10
|
115 (testing "a griffin is a mammal, indirectly through mammal and bird"
|
|
rlm@10
|
116 (is (isa? diamond ::griffin ::animal)))
|
|
rlm@10
|
117 (testing "a griffin is a bird"
|
|
rlm@10
|
118 (is (isa? diamond ::griffin ::bird)))
|
|
rlm@10
|
119 (testing "after underive, griffin is no longer a bird"
|
|
rlm@10
|
120 (is (not (isa? bird-no-more ::griffin ::bird))))
|
|
rlm@10
|
121 (testing "but it is still an animal, via mammal"
|
|
rlm@10
|
122 (is (isa? bird-no-more ::griffin ::animal)))))
|
|
rlm@10
|
123
|
|
rlm@10
|
124 (deftest derivation-world-bridges-to-java-inheritance
|
|
rlm@10
|
125 (let [h (derive (make-hierarchy) java.util.Map ::map)]
|
|
rlm@10
|
126 (testing "a Java class can be isa? a tag"
|
|
rlm@10
|
127 (is (isa? h java.util.Map ::map)))
|
|
rlm@10
|
128 (testing "if a Java class isa? a tag, so are its subclasses..."
|
|
rlm@10
|
129 (is (isa? h java.util.HashMap ::map)))
|
|
rlm@10
|
130 (testing "...but not its superclasses!"
|
|
rlm@10
|
131 (is (not (isa? h java.util.Collection ::map))))))
|
|
rlm@10
|
132
|
|
rlm@10
|
133 (deftest global-hierarchy-test
|
|
rlm@10
|
134 (with-var-roots {#'clojure.core/global-hierarchy (make-hierarchy)}
|
|
rlm@10
|
135 (assert-valid-hierarchy @#'clojure.core/global-hierarchy)
|
|
rlm@10
|
136 (testing "when you add some derivations..."
|
|
rlm@10
|
137 (derive ::lion ::cat)
|
|
rlm@10
|
138 (derive ::manx ::cat)
|
|
rlm@10
|
139 (assert-valid-hierarchy @#'clojure.core/global-hierarchy))
|
|
rlm@10
|
140 (testing "...isa? sees the derivations"
|
|
rlm@10
|
141 (is (isa? ::lion ::cat))
|
|
rlm@10
|
142 (is (not (isa? ::cat ::lion))))
|
|
rlm@10
|
143 (testing "... you can traverse the derivations"
|
|
rlm@10
|
144 (is (= #{::manx ::lion} (descendants ::cat)))
|
|
rlm@10
|
145 (is (= #{::cat} (parents ::manx)))
|
|
rlm@10
|
146 (is (= #{::cat} (ancestors ::manx))))
|
|
rlm@10
|
147 (testing "then, remove a derivation..."
|
|
rlm@10
|
148 (underive ::manx ::cat))
|
|
rlm@10
|
149 (testing "... traversals update accordingly"
|
|
rlm@10
|
150 (is (= #{::lion} (descendants ::cat)))
|
|
rlm@10
|
151 (is (nil? (parents ::manx)))
|
|
rlm@10
|
152 (is (nil? (ancestors ::manx))))))
|
|
rlm@10
|
153
|
|
rlm@10
|
154 #_(defmacro for-all
|
|
rlm@10
|
155 "Better than the actual for-all, if only it worked."
|
|
rlm@10
|
156 [& args]
|
|
rlm@10
|
157 `(reduce
|
|
rlm@10
|
158 #(and %1 %2)
|
|
rlm@10
|
159 (map true? (for ~@args))))
|
|
rlm@10
|
160
|
