diff --git a/test/clojure/core_test/descendants.cljc b/test/clojure/core_test/descendants.cljc new file mode 100644 index 0000000..ffaf5a6 --- /dev/null +++ b/test/clojure/core_test/descendants.cljc @@ -0,0 +1,128 @@ +(ns clojure.core-test.descendants + (:require [clojure.test :refer [are deftest is testing use-fixtures]] + [clojure.core-test.portability #?(:cljs :refer-macros :default :refer) [when-var-exists]])) + +(when-var-exists descendants + + ; Some types for testing descendants by type + (defprotocol TestDescendantsProtocol) + (defrecord TestDescendantsRecord [] TestDescendantsProtocol) + (deftype TestDescendantsType [] TestDescendantsProtocol) + + ; A global hierarchy for testing `descendants tag` and `descendants h tag` + (def global-hierarchy [[TestDescendantsRecord ::record] + [::t ::p-1] + [::t ::p-2] + [::p-1 'ns/p-0] + [::p-2 ::root] + ['ns/p-0 ::root]]) + + (defn register-global-hierarchy [] + (doseq [[tag parent] global-hierarchy] + (derive tag parent))) + + (defn unregister-global-hierarchy [] + (doseq [[tag parent] global-hierarchy] + (underive tag parent))) + + (defn with-global-hierarchy [tests] + (register-global-hierarchy) + (tests) + (unregister-global-hierarchy)) + + (use-fixtures :once with-global-hierarchy) + + ; A hierarchy for testing `descendants h tag` + (def datatypes + (-> (make-hierarchy) + (derive TestDescendantsRecord ::datatype) + (derive TestDescendantsType ::datatype) + (derive TestDescendantsType ::mutable))) + + ; Another hierarchy for testing `descendants h tag` + (def diamond + (-> (make-hierarchy) + (derive ::a ::root) + (derive ::b ::a) + (derive ::c ::a) + (derive ::d ::b) + (derive ::d ::c))) + + (deftest test-descendants + + (testing "descendants tag" + + (testing "returns descendants by relationship globally defined with derive" + (are [expected tag] (= expected (descendants tag)) + nil ::t + #{::t ::p-1} 'ns/p-0 + #{::t ::p-1 ::p-2 'ns/p-0} ::root + #{::t} ::p-2 + #{#?(:bb 'clojure.core_test.descendants/TestDescendantsRecord :default TestDescendantsRecord)} ::record)) + + (testing "cannot get descendants by type inheritance" + (is (nil? (descendants TestDescendantsProtocol))) + #?(:cljs (is (nil? (descendants js/Object))) + :default (is (thrown? Exception (descendants Object))))) + + (testing "does not throw on invalid tag" + (are [tag] (nil? (descendants tag)) + nil + "anything" + 42 + 3.14 + true + false + [] + {} + #{} + '()))) + + (testing "descendants h tag" + + (testing "returns only descendants declared in h, whether the tag is in global hierarchy or not" + (are [expected h tag] (= expected (descendants h tag)) + + ; tag in h and not in global hierarchy + nil diamond ::d + #{::d} diamond ::b + #{::b ::c ::d} diamond ::a + #?(:bb #{'clojure.core_test.descendants/TestDescendantsRecord 'clojure.core_test.descendants/TestDescendantsType} + :default #{TestDescendantsRecord TestDescendantsType}) datatypes ::datatype + #?(:bb #{'clojure.core_test.descendants/TestDescendantsType} + :default #{TestDescendantsType}) datatypes ::mutable + + ; tag in both h and global hierarchy, only descendants in h are returned + #{::a ::b ::c ::d} diamond ::root + + ; tag not in h but in global hierarchy + nil datatypes ::root + nil datatypes ::p-1 + nil datatypes ::p-2 + + ; tag neither in h nor in global hierarchy + nil datatypes ::d + nil datatypes ::b + nil datatypes ::a)) + + (testing "cannot get descendants by type inheritance, whether the tag is in h or not" + (are [h] #?(:cljs (nil? (descendants h js/Object)) + :default (thrown? Exception (descendants h Object))) + ; tag in h + (derive (make-hierarchy) Object ::object) + ; tag not in h + diamond + datatypes)) + + (testing "does not throw on invalid tag or hierarchy" + (are [invalid] (nil? (descendants invalid invalid)) + nil + "anything" + 42 + 3.14 + true + false + [] + {} + #{} + '())))))