1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
|
; Copyright (c) Rich Hickey. All rights reserved.
; The use and distribution terms for this software are covered by the
; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
; which can be found in the file epl-v10.html at the root of this distribution.
; By using this software in any fashion, you are agreeing to be bound by
; the terms of this license.
; You must not remove this notice, or any other, from this software.
; Author: Frantisek Sodomka, Robert Lachlan
(ns clojure.test-clojure.multimethods
(:use clojure.test [clojure.test-helper :only (with-var-roots)])
(:require [clojure.set :as set]))
; http://clojure.org/multimethods
; defmulti
; defmethod
; remove-method
; prefer-method
; methods
; prefers
(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))))
(deftest basic-multimethod-test
(testing "Check basic dispatch"
(defmulti too-simple identity)
(defmethod too-simple :a [x] :a)
(defmethod too-simple :b [x] :b)
(defmethod too-simple :default [x] :default)
(is (= :a (too-simple :a)))
(is (= :b (too-simple :b)))
(is (= :default (too-simple :c))))
(testing "Remove a method works"
(remove-method too-simple :a)
(is (= :default (too-simple :a))))
(testing "Add another method works"
(defmethod too-simple :d [x] :d)
(is (= :d (too-simple :d)))))
(deftest isA-multimethod-test
(testing "Dispatch on isA"
;; Example from the multimethod docs.
(derive java.util.Map ::collection)
(derive java.util.Collection ::collection)
(defmulti foo class)
(defmethod foo ::collection [c] :a-collection)
(defmethod foo String [s] :a-string)
(is (= :a-collection (foo [])))
(is (= :a-collection (foo (java.util.HashMap.))))
(is (= :a-string (foo "bar")))))
(deftest preferences-multimethod-test
(testing "Multiple method match dispatch error is caught"
;; Example from the multimethod docs.
(derive ::rect ::shape)
(defmulti bar (fn [x y] [x y]))
(defmethod bar [::rect ::shape] [x y] :rect-shape)
(defmethod bar [::shape ::rect] [x y] :shape-rect)
(is (thrown? java.lang.IllegalArgumentException
(bar ::rect ::rect))))
(testing "The prefers method returns empty table w/ no prefs"
(= {} (prefers bar)))
(testing "Adding a preference to resolve it dispatches correctly"
(prefer-method bar [::rect ::shape] [::shape ::rect])
(is (= :rect-shape (bar ::rect ::rect))))
(testing "The prefers method now returns the correct table"
(is (= {[::rect ::shape] #{[::shape ::rect]}} (prefers bar)))))
(deftest remove-all-methods-test
(testing "Core function remove-all-methods works"
(defmulti simple1 identity)
(defmethod simple1 :a [x] :a)
(defmethod simple1 :b [x] :b)
(is (= {} (methods (remove-all-methods simple1))))))
(deftest methods-test
(testing "Core function methods works"
(defmulti simple2 identity)
(defmethod simple2 :a [x] :a)
(defmethod simple2 :b [x] :b)
(is (= #{:a :b} (into #{} (keys (methods simple2)))))
(is (= :a ((:a (methods simple2)) 1)))
(defmethod simple2 :c [x] :c)
(is (= #{:a :b :c} (into #{} (keys (methods simple2)))))
(remove-method simple2 :a)
(is (= #{:b :c} (into #{} (keys (methods simple2)))))))
(deftest get-method-test
(testing "Core function get-method works"
(defmulti simple3 identity)
(defmethod simple3 :a [x] :a)
(defmethod simple3 :b [x] :b)
(is (fn? (get-method simple3 :a)))
(is (= (:a ((get-method simple3 :a) 1))))
(is (fn? (get-method simple3 :b)))
(is (= (:b ((get-method simple3 :b) 1))))
(is (nil? (get-method simple3 :c)))))
|
