clojure-test-suite/test/clojure/core_test/derive.cljc at a148a09045a2c43594bc2c5f709cdc0209330dbd · jank-lang/clojure-test-suite · GitHub

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
(ns clojure.core-test.derive
  (:require [clojure.test :refer [are deftest is testing]]
            [clojure.core-test.portability #?(:cljs :refer-macros :default :refer) [when-var-exists] :as p]))

(when-var-exists derive
  (deftest test-derive

    (testing "derive tag parent"
      (are [tag parent] (let [success (and (nil? (derive tag parent))
                                           (isa? tag parent))]
                          ; cleanup global hierarchy not to interfere with other tests
                          (underive tag parent)
                          success)
                        ::rect ::shape
                        'n/a 'n/b
                        #?(:cljs js/String :lpy python/str :phel stdClass :default String) ::object))

    (testing "derive h tag parent"
      (are [expected h tag parent] (= expected (derive h tag parent))

                                   ; `derive h tag parent` seems to accept non-namespaced tag/parent on all platforms
                                   ; https://ask.clojure.org/index.php/14759/derive-tag-parent-accepts-namespaced-keyword-symbol-parent
                                   {:ancestors   {:rect #{:shape}}
                                    :descendants {:shape #{:rect}}
                                    :parents     {:rect #{:shape}}} (make-hierarchy) :rect :shape

                                   {:ancestors   {::rect #{::shape}}
                                    :descendants {::shape #{::rect}}
                                    :parents     {::rect #{::shape}}} (make-hierarchy) ::rect ::shape

                                   {:ancestors   {'n/a #{'n/b}}
                                    :descendants {'n/b #{'n/a}}
                                    :parents     {'n/a #{'n/b}}} (make-hierarchy) 'n/a 'n/b

                                   {:ancestors   {#?(:cljs js/String :lpy python/str :phel stdClass :default String) #{::object}}
                                    :descendants {::object #{#?(:cljs js/String :lpy python/str :phel stdClass :default String)}}
                                    :parents     {#?(:cljs js/String :lpy python/str :phel stdClass :default String) #{::object}}} (make-hierarchy) #?(:cljs js/String :lpy python/str :phel stdClass :default String) ::object

                                   {:ancestors   {::rect #{::shape}, ::square #{::rect ::shape}}
                                    :descendants {::rect #{::square}, ::shape #{::rect ::square}}
                                    :parents     {::rect #{::shape}, ::square #{::rect}}} (derive (make-hierarchy) ::rect ::shape) ::square ::rect

                                   {:ancestors   {::rect #{::shape}}
                                    :descendants {::shape #{::rect}}
                                    :parents     {::rect #{::shape}}} (derive (make-hierarchy) ::rect ::shape) ::rect ::shape

                                   {:ancestors   {::rect #{::shape}}
                                    :descendants {::shape #{::rect}}
                                    :parents     {::rect #{::shape}}} {:parents {} :descendants {} :ancestors {}} ::rect ::shape))

    (testing "cyclic derivation"
      (is (p/thrown? (derive ::a ::a)))
      (let [h (-> (make-hierarchy) (derive ::a ::b) (derive ::b ::c))]
        (is (p/thrown? (derive h ::c ::a)))))

    (testing "bad shapes"

      (testing "nils"
        (are [tag parent] (p/thrown? (derive tag parent))
                          nil nil
                          ::tag nil))

      #?(:bb      "bb allows non-namespaced tags"           ; https://github.com/babashka/babashka/issues/1890
         :cljs    "cljs allows non-namespaced tags"         ; https://ask.clojure.org/index.php/14759/derive-tag-parent-accepts-namespaced-keyword-symbol-parent
         :default (testing "non-namespaced tag"
                    (are [tag parent] (p/thrown? (derive tag parent))
                                      :a ::b
                                      'a 'n/b)))

      #?(:bb      "bb allows non-namespaced parents"        ; https://github.com/babashka/babashka/issues/1890
         :default (testing "non-namespaced parent"
                    (are [tag parent] (p/thrown? (derive tag parent))
                                      :a :b
                                      ::a :b
                                      'a 'b
                                      'n/a 'b
                                      #?(:cljs js/String :lpy python/str :phel stdClass :default String) :b)))

      (testing "more invalid parents"
        (are [tag parent] (p/thrown? (derive tag parent))
                          ::tag #?(:cljs js/String :lpy python/str :phel stdClass :default String)
                          ::tag 42
                          ::tag "parent"))

      (testing "invalid hierarchy"
        (are [h tag parent] (p/thrown? (derive h tag parent))
                            nil ::a ::b
                            {} ::a ::b
                            {:parents {} :descendants {}} ::a ::b
                            {:parents nil :descendants {} :ancestors {}} ::a ::b
                            ::z ::a ::b
                            true ::a ::b
                            42 ::a ::b
                            3.14 ::a ::b)))))