1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/src/clojure/test_clojure/multimethods.clj	Sat Aug 21 06:25:44 2010 -0400
     1.3 @@ -0,0 +1,160 @@
     1.4 +;   Copyright (c) Rich Hickey. All rights reserved.
     1.5 +;   The use and distribution terms for this software are covered by the
     1.6 +;   Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
     1.7 +;   which can be found in the file epl-v10.html at the root of this distribution.
     1.8 +;   By using this software in any fashion, you are agreeing to be bound by
     1.9 +;   the terms of this license.
    1.10 +;   You must not remove this notice, or any other, from this software.
    1.11 +
    1.12 +; Author: Frantisek Sodomka, Robert Lachlan
    1.13 +
    1.14 +(ns clojure.test-clojure.multimethods
    1.15 +  (:use clojure.test [clojure.test-clojure.helpers :only (with-var-roots)])
    1.16 +  (:require [clojure.set :as set]))
    1.17 +
    1.18 +; http://clojure.org/multimethods
    1.19 +
    1.20 +; defmulti
    1.21 +; defmethod
    1.22 +; remove-method
    1.23 +; prefer-method
    1.24 +; methods
    1.25 +; prefers
    1.26 +
    1.27 +(defmacro for-all
    1.28 +  [& args]
    1.29 +  `(dorun (for ~@args)))
    1.30 +
    1.31 +(defn hierarchy-tags
    1.32 +  "Return all tags in a derivation hierarchy"
    1.33 +  [h]
    1.34 +  (set/select
    1.35 +   #(instance? clojure.lang.Named %)
    1.36 +   (reduce into #{} (map keys (vals h)))))
    1.37 +
    1.38 +(defn transitive-closure
    1.39 +  "Return all objects reachable by calling f starting with o,
    1.40 +   not including o itself. f should return a collection."
    1.41 +  [o f]
    1.42 +  (loop [results #{}
    1.43 +         more #{o}]
    1.44 +    (let [new-objects (set/difference more results)]
    1.45 +      (if (seq new-objects)
    1.46 +        (recur (set/union results more) (reduce into #{} (map f new-objects)))
    1.47 +        (disj results o)))))
    1.48 +
    1.49 +(defn tag-descendants
    1.50 +  "Set of descedants which are tags (i.e. Named)."
    1.51 +  [& args]
    1.52 +  (set/select
    1.53 +   #(instance? clojure.lang.Named %)
    1.54 +   (or (apply descendants args) #{})))
    1.55 +
    1.56 +(defn assert-valid-hierarchy
    1.57 +  [h]
    1.58 +  (let [tags (hierarchy-tags h)]
    1.59 +    (testing "ancestors are the transitive closure of parents"
    1.60 +      (for-all [tag tags]
    1.61 +        (is (= (transitive-closure tag #(parents h %))
    1.62 +               (or (ancestors h tag) #{})))))
    1.63 +    (testing "ancestors are transitive"
    1.64 +      (for-all [tag tags]
    1.65 +        (is (= (transitive-closure tag #(ancestors h %))
    1.66 +               (or (ancestors h tag) #{})))))
    1.67 +    (testing "tag descendants are transitive"
    1.68 +      (for-all [tag tags]
    1.69 +        (is (= (transitive-closure tag #(tag-descendants h %))
    1.70 +               (or (tag-descendants h tag) #{})))))
    1.71 +    (testing "a tag isa? all of its parents"
    1.72 +      (for-all [tag tags
    1.73 +               :let [parents (parents h tag)]
    1.74 +               parent parents]
    1.75 +        (is (isa? h tag parent))))
    1.76 +    (testing "a tag isa? all of its ancestors"
    1.77 +      (for-all [tag tags
    1.78 +               :let [ancestors (ancestors h tag)]
    1.79 +               ancestor ancestors]
    1.80 +        (is (isa? h tag ancestor))))
    1.81 +    (testing "all my descendants have me as an ancestor"
    1.82 +      (for-all [tag tags
    1.83 +               :let [descendants (descendants h tag)]
    1.84 +                descendant descendants]
    1.85 +        (is (isa? h descendant tag))))
    1.86 +    (testing "there are no cycles in parents"
    1.87 +      (for-all [tag tags]
    1.88 +        (is (not (contains? (transitive-closure tag #(parents h %)) tag)))))
    1.89 +    (testing "there are no cycles in descendants"
    1.90 +      (for-all [tag tags]
    1.91 +        (is (not (contains? (descendants h tag) tag)))))))
    1.92 +
    1.93 +(def family
    1.94 +  (reduce #(apply derive (cons %1 %2)) (make-hierarchy)
    1.95 +          [[::parent-1 ::ancestor-1]
    1.96 +           [::parent-1 ::ancestor-2]
    1.97 +           [::parent-2 ::ancestor-2]
    1.98 +           [::child ::parent-2]
    1.99 +           [::child ::parent-1]]))
   1.100 +
   1.101 +(deftest cycles-are-forbidden
   1.102 +  (testing "a tag cannot be its own parent"
   1.103 +    (is (thrown-with-msg? Throwable #"\(not= tag parent\)"
   1.104 +          (derive family ::child ::child))))
   1.105 +  (testing "a tag cannot be its own ancestor"
   1.106 +    (is (thrown-with-msg? Throwable #"Cyclic derivation: :clojure.test-clojure.multimethods/child has :clojure.test-clojure.multimethods/ancestor-1 as ancestor"
   1.107 +          (derive family ::ancestor-1 ::child)))))
   1.108 +
   1.109 +(deftest using-diamond-inheritance
   1.110 +  (let [diamond (reduce #(apply derive (cons %1 %2)) (make-hierarchy)
   1.111 +                        [[::mammal ::animal]
   1.112 +                         [::bird ::animal]
   1.113 +                         [::griffin ::mammal]
   1.114 +                         [::griffin ::bird]])
   1.115 +        bird-no-more (underive diamond ::griffin ::bird)]
   1.116 +    (assert-valid-hierarchy diamond)
   1.117 +    (assert-valid-hierarchy bird-no-more)
   1.118 +    (testing "a griffin is a mammal, indirectly through mammal and bird"
   1.119 +      (is (isa? diamond ::griffin ::animal)))
   1.120 +    (testing "a griffin is a bird"
   1.121 +      (is (isa? diamond ::griffin ::bird)))
   1.122 +    (testing "after underive, griffin is no longer a bird"
   1.123 +      (is (not (isa? bird-no-more ::griffin ::bird))))
   1.124 +    (testing "but it is still an animal, via mammal"
   1.125 +      (is (isa? bird-no-more ::griffin ::animal)))))
   1.126 +
   1.127 +(deftest derivation-world-bridges-to-java-inheritance
   1.128 +  (let [h (derive (make-hierarchy) java.util.Map ::map)]
   1.129 +    (testing "a Java class can be isa? a tag"
   1.130 +      (is (isa? h java.util.Map ::map)))
   1.131 +    (testing "if a Java class isa? a tag, so are its subclasses..."
   1.132 +      (is (isa? h java.util.HashMap ::map)))
   1.133 +    (testing "...but not its superclasses!"
   1.134 +      (is (not (isa? h java.util.Collection ::map))))))
   1.135 +
   1.136 +(deftest global-hierarchy-test
   1.137 +  (with-var-roots {#'clojure.core/global-hierarchy (make-hierarchy)}
   1.138 +    (assert-valid-hierarchy @#'clojure.core/global-hierarchy)
   1.139 +    (testing "when you add some derivations..."
   1.140 +      (derive ::lion ::cat)
   1.141 +      (derive ::manx ::cat)
   1.142 +      (assert-valid-hierarchy @#'clojure.core/global-hierarchy))
   1.143 +    (testing "...isa? sees the derivations"
   1.144 +      (is (isa? ::lion ::cat))
   1.145 +      (is (not (isa? ::cat ::lion))))
   1.146 +    (testing "... you can traverse the derivations"
   1.147 +      (is (= #{::manx ::lion} (descendants ::cat)))
   1.148 +      (is (= #{::cat} (parents ::manx)))
   1.149 +      (is (= #{::cat} (ancestors ::manx))))
   1.150 +    (testing "then, remove a derivation..."
   1.151 +      (underive ::manx ::cat))
   1.152 +    (testing "... traversals update accordingly"
   1.153 +      (is (= #{::lion} (descendants ::cat)))
   1.154 +      (is (nil? (parents ::manx)))
   1.155 +      (is (nil? (ancestors ::manx))))))
   1.156 +
   1.157 +#_(defmacro for-all
   1.158 +  "Better than the actual for-all, if only it worked."
   1.159 +  [& args]
   1.160 +  `(reduce
   1.161 +    #(and %1 %2)
   1.162 +    (map true? (for ~@args))))
   1.163 +