diff --git a/README.md b/README.md index 96d6c67..d4e1960 100644 --- a/README.md +++ b/README.md @@ -2,7 +2,9 @@ # _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_ @@ -10,8 +12,18 @@ 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. diff --git a/deps.edn b/deps.edn index 6bb56e0..fcf3bd3 100644 --- a/deps.edn +++ b/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"}}} diff --git a/dev/user.clj b/dev/user.clj index 112e4f1..09c6eff 100644 --- a/dev/user.clj +++ b/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) diff --git a/resources/clj-kondo.exports/hierarchy/hierarchy/config.edn b/resources/clj-kondo.exports/hierarchy/hierarchy/config.edn index 0967ef4..9b892af 100644 --- a/resources/clj-kondo.exports/hierarchy/hierarchy/config.edn +++ b/resources/clj-kondo.exports/hierarchy/hierarchy/config.edn @@ -1 +1 @@ -{} +{:lint-as {clojure.test.check.clojure-test/defspec clojure.test/deftest}} diff --git a/src/hierarchy/core.clj b/src/hierarchy/core.clj index 541ba87..24c4887 100644 --- a/src/hierarchy/core.clj +++ b/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+))) diff --git a/test/hierarchy/core_test.clj b/test/hierarchy/core_test.clj index f5d69bd..31fd782 100644 --- a/test/hierarchy/core_test.clj +++ b/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!)))