From 0a69222eed2c60ecb8b755e02d5193075e70be1b Mon Sep 17 00:00:00 2001
From: Antoine Belvire <antoine.belvire@opensuse.org>
Date: Thu, 20 Nov 2025 19:17:27 +0100
Subject: [PATCH] Test underive

This closes #546.
---
 test/clojure/core_test/underive.cljc | 78 ++++++++++++++++++++++++++++
 1 file changed, 78 insertions(+)
 create mode 100644 test/clojure/core_test/underive.cljc

diff --git a/test/clojure/core_test/underive.cljc b/test/clojure/core_test/underive.cljc
new file mode 100644
index 00000000..cf0ab445
--- /dev/null
+++ b/test/clojure/core_test/underive.cljc
@@ -0,0 +1,78 @@
+(ns clojure.core-test.underive
+  (:require [clojure.test :refer [are deftest is testing]]
+            [clojure.core-test.portability #?(:cljs :refer-macros :default :refer) [when-var-exists]]))
+
+(when-var-exists
+  underive
+
+  (def shape-hierarchy
+    (-> (make-hierarchy)
+        (derive ::circle ::shape)
+        (derive ::rect ::shape)
+        (derive ::square ::rect)))
+
+  (def diamond-hierarchy
+    (-> (make-hierarchy)
+        (derive ::b ::a)
+        (derive ::c ::a)
+        (derive ::d ::b)
+        (derive ::d ::c)))
+
+  (deftest test-underive
+
+    (testing "underive tag parent"
+
+      (testing "when tag is child of parent"
+        (derive ::t ::p)
+        (is (isa? ::t ::p))
+        (is (nil? (underive ::t ::p)))
+        (is (not (isa? ::t ::p))))
+
+      (testing "when tag is not child of parent"
+        (are [tag parent] (nil? (underive tag parent))
+                          ::square ::rect
+                          ::square ::shape
+                          ::rect ::shape
+                          nil nil
+                          :a :a
+                          'a 'b
+                          42 3.14
+                          true false)))
+
+    (testing "underive h tag parent"
+
+      (testing "when tag is child of parent in h"
+        (are [expected h tag parent] (= expected (underive h tag parent))
+
+                                     {:ancestors   {::circle #{::shape}, ::rect #{::shape}}
+                                      :descendants {::shape #{::circle ::rect}}
+                                      :parents     {::circle #{::shape}, ::rect #{::shape}}} shape-hierarchy ::square ::rect
+
+                                     {:ancestors   {::circle #{::shape}, ::square #{::rect}}
+                                      :descendants {::shape #{::circle}, ::rect #{::square}}
+                                      :parents     {::circle #{::shape}, ::square #{::rect}}} shape-hierarchy ::rect ::shape
+
+                                     {:parents     {::b #{::a}, ::c #{::a}, ::d #{::c}},
+                                      :ancestors   {::b #{::a}, ::c #{::a}, ::d #{::a ::c}},
+                                      :descendants {::a #{::d ::b ::c}, ::c #{::d}}} diamond-hierarchy ::d ::b
+
+                                     {:parents     {::b #{::a}, ::c #{::a}},
+                                      :ancestors   {::b #{::a}, ::c #{::a}},
+                                      :descendants {::a #{::b ::c}}} (underive diamond-hierarchy ::d ::b) ::d ::c))
+
+      (testing "when tag is not child of parent in h"
+        (are [h tag parent] (= h (underive h tag parent))
+                            shape-hierarchy ::rect ::square
+                            shape-hierarchy ::square ::shape
+                            diamond-hierarchy ::b ::d
+                            diamond-hierarchy ::d ::a)))
+
+    (testing "bad shape"
+      (are [h tag parent] (thrown? #?(:cljs js/Error :default Exception) (underive h tag parent))
+                          nil ::a ::b
+                          {} ::a ::b
+                          [[:parents {}] [:descendants {}] [:ancestors {}]] ::a ::b
+                          ::z ::a ::b
+                          true ::a ::b
+                          42 ::a ::b
+                          3.14 ::a ::b))))