feat: hierarchy cleanup and implement using core hierarchy

dev/user.clj

@@ -1,13 +1,11 @@
 (ns user
-  (:refer-clojure :exclude [derive underive])
   (:require [criterium.core :refer [report-result
                                     quick-benchmark] :as crit]
             [clara.rules.platform :refer [compute-for]]
             [clojure.core.async :refer [go timeout <!]]
             [clara.rules :refer [defrule defquery defhierarchy
                                  insert! insert-all! insert insert-all fire-rules query
-                                 mk-session clear-ns-vars!
-                                 derive! underive!]]
+                                 mk-session clear-ns-vars!]]
             [clara.rules.compiler :as com]
             [clojure.core.cache.wrapped :as cache]
             [schema.core :as sc]
@@ -22,10 +20,8 @@
   (tap> "foobar"))
 
 (defhierarchy foobar
-  (derive! :thing/foo :thing/that)
-  (doseq [x (range 20)]
-    (derive! [:thing/foo (- 20 x)] [:thing/that (- 20 x)]))
-  (derive! :thing/bar :thing/that))
+  :thing/foo :thing/that
+  :thing/bar :thing/that)
 
 (defrule return-a-thing
   [:thing/that [{:keys [value]}] (= value ?value)]

src/main/clojure/clara/rules.clj

@@ -1,7 +1,6 @@
 (ns clara.rules
   "Forward-chaining rules for Clojure. The primary API is in this namespace."
   (:require [clara.rules.engine :as eng]
-            [clara.rules.hierarchy :as hierarchy]
             [clara.rules.platform :as platform]
             [clara.rules.compiler :as com]
             [clara.rules.dsl :as dsl]))
@@ -316,28 +315,25 @@
     `(def ~(vary-meta name assoc :query true :doc doc)
        ~(dsl/build-query name body (meta &form)))))
 
-(defn derive!
-  [child parent]
-  (hierarchy/derive child parent))
-
-(defn underive!
-  [child parent]
-  (hierarchy/underive child parent))
-
 (defmacro defhierarchy
   "Defines a hierarchy and stores it in the given var. For instance, a simple hierarchy that adds
   several child->parent relationships would look like this:
   (defhierarchy order-types
     \"Defines several order types\"
-    (derive! :order/hvac :order/service)
-    (derive! :order/plumber :order/service)
-    (underive! :order/cinema :order/service))
-  See the [hierarchy authoring documentation](http://www.clara-rules.org)"
+    :order/hvac     :order/service
+    :order/plumber  :order/service
+    :order/cinema   :order/service)"
   [name & body]
-  (let [doc (if (string? (first body)) (first body) nil)]
+  (let [doc (if (and (string? (first body))
+                     (odd? (count body)))
+               (first body)
+               nil)
+        derive-seq (if doc (rest body) body)
+        derive-all (for [[tag parent] (partition 2 derive-seq)]
+                     (list 'clojure.core/derive tag parent))]
     `(def ~(vary-meta name assoc :hierarchy true :doc doc)
-       (binding [hierarchy/*hierarchy* (atom (hierarchy/make-hierarchy))]
-         ~@body))))
+       (-> (make-hierarchy)
+           ~@derive-all))))
 
 (defmacro clear-ns-vars!
   "Ensures that any rule/query definitions which have been cached will be cleared from the associated namespace.

src/main/clojure/clara/rules/compiler.clj

@@ -5,9 +5,7 @@
   (:require [clara.rules.engine :as eng]
             [clara.rules.schema :as schema]
             [clara.rules.platform :refer [jeq-wrap] :as platform]
-            [clara.rules.hierarchy :as hierarchy]
             [clojure.core.cache.wrapped :as cache]
-            [clj-commons.digest :as digest]
             [ham-fisted.api :as hf]
             [ham-fisted.set :as hs]
             [ham-fisted.mut-map :as hm]
@@ -180,8 +178,6 @@
 
 (def ^:dynamic *compile-ctx* nil)
 
-(def ^:dynamic *hierarchy* nil)
-
 (defn try-eval
   "Evals the given `expr`.  If an exception is thrown, it is caught and an
    ex-info exception is thrown with more details added.  Uses *compile-ctx*
@@ -2165,20 +2161,13 @@
     (var? source)
     (load-hierarchies-from-source @source)
 
-    (:hierarchy-data source)
+    (and (:parents source)
+         (:ancestors source)
+         (:descendants source))
     [source]
 
     :else []))
 
-(defn- reduce-hierarchy
-  [h {:keys [hierarchy-data]}]
-  (reduce (fn apply-op
-            [h [op tag parent]]
-            (case op
-              :d (hierarchy/derive h tag parent)
-              :u (hierarchy/underive h tag parent)
-              (throw (ex-info "Unsupported operation building hierarchy" {:op op})))) h hierarchy-data))
-
 (defn mk-session
   "Creates a new session using the given rule source. The resulting session
   is immutable, and can be used with insert, retract, fire-rules, and query functions."
@@ -2192,10 +2181,16 @@
                               (into (sorted-set-by production-load-order-comp) productions-unique)
                               ;; Store the name of the custom comparator for durability.
                               {:clara.rules.durability/comparator-name `production-load-order-comp})
+         options-hierarchy (get options :hierarchy)
          hierarchies-loaded (cond->> (mapcat load-hierarchies-from-source sources)
-                              (:hierarchy options) (cons (:hierarchy options)))
+                              options-hierarchy
+                              (cons (:hierarchy options)))
          hierarchy (when (seq hierarchies-loaded)
-                     (reduce reduce-hierarchy (hierarchy/make-hierarchy) hierarchies-loaded))
+                     (->> (for [{:keys [parents]} hierarchies-loaded
+                                [tag parent-set] parents
+                                parent parent-set]
+                            [tag parent])
+                          (reduce (partial apply derive) (make-hierarchy))))
          options (cond-> options
                    (some? hierarchy)
                    (assoc :hierarchy hierarchy))

src/main/clojure/clara/rules/hierarchy.clj

@@ -4,82 +4,80 @@
                             make-hierarchy])
   (:require [clojure.core :as core]))
 
-(defn make-hierarchy
-  []
-  (-> (core/make-hierarchy)
-      (assoc :hierarchy-data [])))
-
-(def ^:dynamic *hierarchy* nil)
+(defonce ^:private derive' core/derive)
 
-(defn- derive*
-  [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)))
+(defonce ^:private underive' core/underive)
 
-(defn- underive*
-  [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)) (make-hierarchy)
-              deriv-seq)
-      h)))
-
-(defn derive
+(defn derive+
   "Establishes a parent/child relationship between parent and
   tag. Both tag and parent cannot be null, h must be a hierarchy obtained from make-hierarchy.
   Unlike `clojure.core/underive`, there is no restriction
   on the type of values that tag and parent can be.
-  When only two tag and parent are passed, this function modifies the *hierarchy* atom."
+  When only two tag and parent are passed, this function modifies the global hierarchy."
   ([tag parent]
-   (assert *hierarchy* "*hierarchy* must be bound")
-   (swap! *hierarchy* derive tag parent))
+   (alter-var-root #'core/global-hierarchy derive+ tag parent))
   ([h tag parent]
-   (-> (derive* h tag parent)
-       (update :hierarchy-data conj [:d 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
+(defn underive+
   "Removes a parent/child relationship between parent and
    tag. h must be a hierarchy obtained from make-hierarchy.
    Unlike `clojure.core/underive`, there is no restriction
    on the type of values that tag and parent can be.
-   When only two tag and parent are passed, this function modifies the *hierarchy* atom."
+   When only two tag and parent are passed, this function modifies the global hierarchy."
   ([tag parent]
-   (assert *hierarchy* "*hierarchy* must be bound")
-   (swap! *hierarchy* underive tag parent))
+   (alter-var-root #'core/global-hierarchy underive+ tag parent))
   ([h tag parent]
-   (-> (underive* h tag parent)
-       (update :hierarchy-data conj [:u 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))))
+
+(defn install!
+  "Installs the derive and underive functions as the clojure.core/derive
+  and clojure.core/underive respectively."
+  []
+  [(alter-var-root #'core/derive (constantly derive+))
+   (alter-var-root #'core/underive (constantly underive+))])
+
+(defn uninstall!
+  "Restores the original clojure.core/derive and clojure.core/underive functions."
+  []
+  [(alter-var-root #'core/derive (constantly derive'))
+   (alter-var-root #'core/underive (constantly underive'))])