Skip to content

Commit

Permalink
feat: add generative tests, cleanup impl
Browse files Browse the repository at this point in the history
  • Loading branch information
k13gomez committed Sep 1, 2024
1 parent 09de9ff commit 4d73a10
Show file tree
Hide file tree
Showing 6 changed files with 184 additions and 13 deletions.
18 changes: 15 additions & 3 deletions README.md
Original file line number Diff line number Diff line change
Expand Up @@ -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.
Expand Down
1 change: 1 addition & 0 deletions deps.edn
Original file line number Diff line number Diff line change
Expand Up @@ -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"}}}

Expand Down
11 changes: 11 additions & 0 deletions dev/user.clj
Original file line number Diff line number Diff line change
@@ -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)
Expand Down
2 changes: 1 addition & 1 deletion resources/clj-kondo.exports/hierarchy/hierarchy/config.edn
Original file line number Diff line number Diff line change
@@ -1 +1 @@
{}
{:lint-as {clojure.test.check.clojure-test/defspec clojure.test/deftest}}
71 changes: 70 additions & 1 deletion src/hierarchy/core.clj
Original file line number Diff line number Diff line change
@@ -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+)))
94 changes: 86 additions & 8 deletions test/hierarchy/core_test.clj
Original file line number Diff line number Diff line change
@@ -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!)))

0 comments on commit 4d73a10

Please sign in to comment.