-
Notifications
You must be signed in to change notification settings - Fork 0
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
feat: add generative tests, cleanup impl
- Loading branch information
Showing
6 changed files
with
184 additions
and
13 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -1 +1 @@ | ||
{} | ||
{:lint-as {clojure.test.check.clojure-test/defspec clojure.test/deftest}} |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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+))) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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!))) |