feat: add generative tests, cleanup impl

README.md

@@ -2,16 +2,28 @@
 
 # _About_
 
-hierarchy is a Clojure library for primarily designed to enhance the built-in hierarchy functions in Clojure, in order to more freely support the use of a variety of value types when calling derive/underive.
+The hierarchy library is an opinionated Clojure library primarily designed to enhance the built-in hierarchy functions,
+it removes the constraints that the hierarchy relationship's parent must be a namespace-qualified symbol or keyword and
+or that child must be either a namespace-qualified symbol or keyword or a class.
 
 # _Usage_
 
 Here's a simple example.
 
 ```clj
 (ns user
-  (:require [hierarchy.core :as h]))
-
+  (:require [hierarchy.core]))
+
+;;; using global hierarchy
+(derive :bar :that)
+(derive :foo :bar)
+(isa? :foo :bar) ;; => true
+
+;;; using via make-hierarchy
+(-> (make-hierarchy)
+    (derive :bar :that)
+    (derive :foo :bar)
+    (isa? :foo :bar)) ;; => true
 ```
 
 See the existing tests for more examples.

deps.edn

@@ -13,6 +13,7 @@
   :test {:extra-paths ["test"]
          :extra-deps {lambdaisland/kaocha {:mvn/version "1.80.1274"}
                       org.clojure/test.check {:mvn/version "1.1.1"}
+                      metosin/malli {:mvn/version "0.16.4"}
                       org.slf4j/slf4j-simple {:mvn/version "2.0.11"}
                       pjstadig/humane-test-output {:mvn/version "0.10.0"}}}
 

dev/user.clj

@@ -1,7 +1,18 @@
 (ns user
   (:require [criterium.core :refer [report-result
+                                    with-progress-reporting
                                     quick-benchmark] :as crit]))
 
+(comment
+  (report-result
+   (with-progress-reporting
+     (quick-benchmark
+      (-> (make-hierarchy)
+          (derive :bar :that)
+          (derive :foo :bar)
+          (isa? :foo :bar))
+      {:verbose true})))) ;; => true
+
 (comment
   (add-tap #'println)
   (remove-tap #'println)

resources/clj-kondo.exports/hierarchy/hierarchy/config.edn

@@ -1 +1 @@
-{}
+{:lint-as {clojure.test.check.clojure-test/defspec clojure.test/deftest}}

src/hierarchy/core.clj

@@ -1 +1,70 @@
-(ns hierarchy.core)
+(ns hierarchy.core
+  (:require [clojure.core :as core]))
+
+(defn derive+
+  "Establishes a parent/child relationship between parent and tag.
+  Unlike `clojure.core/underive`, there is no requirement that
+  tag or parent must be a class, keyword or symbol; h must be a
+  hierarchy obtained from make-hierarchy, if not supplied defaults to,
+  and modifies, the global hierarchy."
+  ([tag parent]
+   (alter-var-root #'core/global-hierarchy derive+ tag parent))
+  ([h tag parent]
+   (assert (some? h))
+   (assert (some? tag))
+   (assert (some? parent))
+   (assert (not= tag parent))
+   (let [tp (:parents h)
+         td (:descendants h)
+         ta (:ancestors h)
+         tf (fn do-transform
+              [m source sources target targets]
+              (reduce (fn [ret k]
+                        (assoc ret k
+                               (reduce conj (get targets k #{}) (cons target (targets target)))))
+                      m (cons source (sources source))))]
+     (or
+      (when-not (contains? (tp tag) parent)
+        (when (contains? (ta tag) parent)
+          h)
+        (when (contains? (ta parent) tag)
+          (throw (Exception. (print-str "Cyclic derivation:" parent "has" tag "as ancestor"))))
+        (-> (assoc-in h [:parents tag] (conj (get tp tag #{}) parent))
+            (update :ancestors tf tag td parent ta)
+            (update :descendants tf parent ta tag td)))
+      h))))
+
+(defn underive+
+  "Removes a parent/child relationship between parent and tag.
+  Unlike `clojure.core/underive`, there is no requirement that
+  tag or parent must be a class, keyword or symbol; h must be a
+  hierarchy obtained from make-hierarchy, if not supplied defaults to,
+  and modifies, the global hierarchy."
+  ([tag parent]
+   (alter-var-root #'core/global-hierarchy underive+ tag parent))
+  ([h tag parent]
+   (assert (some? h))
+   (assert (some? tag))
+   (assert (some? parent))
+   (assert (not= tag parent))
+   (let [parent-map (:parents h)
+         childs-parents (if (parent-map tag)
+                          (disj (parent-map tag) parent) #{})
+         new-parents (if (not-empty childs-parents)
+                       (assoc parent-map tag childs-parents)
+                       (dissoc parent-map tag))
+         deriv-seq (map #(cons (key %) (interpose (key %) (val %)))
+                        (seq new-parents))]
+     (if (contains? (parent-map tag) parent)
+       (reduce (fn do-derive
+                 [h [t p]]
+                 (derive+ h t p))
+               (core/make-hierarchy)
+               deriv-seq)
+       h))))
+
+(when (not= core/derive derive+)
+  (alter-var-root #'core/derive (constantly derive+)))
+
+(when (not= core/underive underive+)
+  (alter-var-root #'core/underive (constantly underive+)))

test/hierarchy/core_test.clj

@@ -1,12 +1,90 @@
 (ns hierarchy.core-test
-  (:require [clojure.test :refer [deftest testing is use-fixtures]]
+  (:require [clojure.test :refer [deftest testing is]]
+            [clojure.test.check.clojure-test :refer [defspec]]
+            [clojure.test.check.generators :as gen]
+            [clojure.test.check.properties :as prop]
             [hierarchy.core :as h]
-            [criterium.core :refer [report-result
-                                    quick-benchmark
-                                    with-progress-reporting]]))
+            [pjstadig.humane-test-output :as hto]
+            [malli.generator :as mg]))
 
-(defn hierarchy-fixture
-  [f]
-  (f))
+(hto/activate!)
 
-(use-fixtures :once hierarchy-fixture)
+(def hierarchy-id
+  [:or
+   [:string]
+   [:keyword]
+   [:symbol]
+   [:qualified-keyword]
+   [:qualified-symbol]])
+
+(def hierarchy-member
+  [:or
+   [:map
+    [:x hierarchy-id]
+    [:y hierarchy-id]]
+   [:vector hierarchy-id]
+   hierarchy-id])
+
+(deftest hierarchy-bindings-are-installed-test
+  (testing "derive is installed"
+    (is (= h/derive+ derive)))
+  (testing "underive is installed"
+    (is (= h/underive+ underive))))
+
+(defspec derive-tests
+  1000
+  (prop/for-all
+   [[foo bar that] (gen/vector-distinct (mg/generator hierarchy-member) {:num-elements 3})]
+   (is (= {:parents {bar #{that}, foo #{bar}},
+           :descendants {that #{bar foo}, bar #{foo}},
+           :ancestors {bar #{that}, foo #{bar that}}}
+          (-> (make-hierarchy)
+              (derive bar that)
+              (derive foo bar))))))
+
+(defspec underive-tests
+  1000
+  (prop/for-all
+   [[foo bar that] (gen/vector-distinct (mg/generator hierarchy-member) {:num-elements 3})]
+   (is (= {:parents {foo #{bar}},
+           :descendants {bar #{foo}},
+           :ancestors {foo #{bar}}}
+          (-> (make-hierarchy)
+              (derive bar that)
+              (derive foo bar)
+              (underive bar that))))))
+
+(defn- reset-global-hierarchy!
+  []
+  (alter-var-root #'clojure.core/global-hierarchy (constantly (make-hierarchy))))
+
+(defn- fetch-global-hierarchy
+  []
+  (-> #'clojure.core/global-hierarchy deref))
+
+(defspec global-derive-tests
+  1000
+  (prop/for-all
+   [[foo bar that] (gen/vector-distinct (mg/generator hierarchy-member) {:num-elements 3})]
+   (reset-global-hierarchy!)
+   (derive bar that)
+   (derive foo bar)
+   (is (= {:parents {bar #{that}, foo #{bar}},
+           :descendants {that #{bar foo}, bar #{foo}},
+           :ancestors {bar #{that}, foo #{bar that}}}
+          (fetch-global-hierarchy)))
+   (reset-global-hierarchy!)))
+
+(defspec global-underive-tests
+  1000
+  (prop/for-all
+   [[foo bar that] (gen/vector-distinct (mg/generator hierarchy-member) {:num-elements 3})]
+   (reset-global-hierarchy!)
+   (derive bar that)
+   (derive foo bar)
+   (underive bar that)
+   (is (= {:parents {foo #{bar}},
+           :descendants {bar #{foo}},
+           :ancestors {foo #{bar}}}
+          (fetch-global-hierarchy)))
+   (reset-global-hierarchy!)))