separate compile-test-handler from test-handler and add env (#485)

* separate compile-test-handler from test-handler and add env

* feat: make some fixes for env support for test-node, add test

* handle PR feedback, update change log, remove println from test

CHANGELOG.md

@@ -1,5 +1,9 @@
 This is a history of changes to clara-rules.
 
+# 0.23.0-SNAPSHOT
+* extract clara.rules.compiler/compile-test-handler from clara.rules.compiler/compile-test
+* add support for `env` inside of test expressions
+
 # 0.22.1
 * fix incorrent lint warning triggered when this binding is not used in clj-kondo hooks
 

src/main/clojure/clara/macros.clj

@@ -131,7 +131,8 @@
           :test
           `(eng/->TestNode
             ~id
-            ~(com/compile-test id (:constraints condition))
+            ~(:env beta-node)
+            ~(com/compile-test id (:constraints condition) (:env beta-node))
             ~(gen-beta-network child-ids beta-graph all-bindings))
 
           :accumulator

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

@@ -403,7 +403,7 @@
         fn-name (mk-node-fn-name "AlphaNode" node-id "AE")]
 
     `(fn ~fn-name [~(add-meta '?__fact__ type)
-          ~destructured-env] ;; TODO: add destructured environment parameter...
+                   ~destructured-env]
        (let [~@assignments
              ~'?__bindings__ (atom ~initial-bindings)]
          ~(compile-constraints constraints)))))
@@ -414,19 +414,25 @@
   (list (symbol (name binding-key))
         (list `-> '?__token__ :bindings binding-key)))
 
-;; FIXME: add env...
-(defn compile-test [node-id constraints]
+(defn compile-test-handler [node-id constraints env]
   (let [binding-keys (variables-as-keywords constraints)
         assignments (mapcat build-token-assignment binding-keys)
 
+        ;; The destructured environment, if any
+        destructured-env (if (> (count env) 0)
+                           {:keys (mapv #(symbol (name %)) (keys env))}
+                           '?__env__)
+
         ;; Hardcoding the node-type and fn-type as we would only ever expect 'compile-test' to be used for this scenario
         fn-name (mk-node-fn-name "TestNode" node-id "TE")]
+    `(fn ~fn-name [~'?__token__ ~destructured-env]
+       (let [~@assignments]
+         (and ~@constraints)))))
 
-    `(let [handler# (fn ~fn-name [~'?__token__]
-                      (let [~@assignments]
-                        (and ~@constraints)))]
-       {:handler handler#
-        :constraints '~constraints})))
+(defn compile-test [node-id constraints env]
+  (let [test-handler (compile-test-handler node-id constraints env)]
+    `(array-map :handler ~test-handler
+                :constraints '~constraints)))
 
 (defn compile-action
   "Compile the right-hand-side action of a rule, returning a function to execute it."
@@ -1438,7 +1444,7 @@
                                                     :msg "compiling negation with join filter node"}})
                         prev)
             :test (handle-expr prev
-                               (compile-test id (:constraints condition))
+                               (compile-test id (:constraints condition) (:env beta-node))
                                id
                                :test-expr
                                {:compile-ctx {:condition condition
@@ -1549,7 +1555,7 @@
    expr-fn-lookup :- schema/NodeFnLookup
    new-bindings :- #{sc/Keyword}]
 
-  (let [{:keys [condition production query join-bindings]} beta-node
+  (let [{:keys [condition production query join-bindings env]} beta-node
 
         condition (if (symbol? condition)
                     (.loadClass (clojure.lang.RT/makeClassLoader) (name condition))
@@ -1603,6 +1609,7 @@
       :test
       (eng/->TestNode
         id
+        env
         (compiled-expr-fn id :test-expr)
         children)
 

src/main/clojure/clara/rules/engine.cljc

@@ -929,7 +929,7 @@
 (defn- test-node-matches
   [node test-handler env token]
   (let [test-result (try
-                      (test-handler token)
+                      (test-handler token env)
                       (catch #?(:clj Exception :cljs :default) e
                         (throw-condition-exception {:cause e
                                                     :node node
@@ -940,7 +940,7 @@
 ;; The test node represents a Rete extension in which an arbitrary test condition is run
 ;; against bindings from ancestor nodes. Since this node
 ;; performs no joins it does not accept right activations or retractions.
-(defrecord TestNode [id test children]
+(defrecord TestNode [id env test children]
   ILeftActivate
   (left-activate [node join-bindings tokens memory transport listener]
     (l/left-activate! listener node tokens)
@@ -951,7 +951,7 @@
      children
      (platform/eager-for
       [token tokens
-       :when (test-node-matches node (:handler test) {} token)]
+       :when (test-node-matches node (:handler test) env token)]
       token)))
 
   (left-retract [node join-bindings tokens memory transport listener]

src/test/clojure/clara/test_rules.clj

@@ -1318,9 +1318,9 @@
 
 ;; Test for: https://github.com/cerner/clara-rules/issues/96
 (deftest test-destructured-binding
-  (let [rule-output (atom nil)
+  (let [rule-output-env (atom nil)
         rule {:name "clara.test-destructured-binding/test-destructured-binding"
-              :env {:rule-output rule-output} ; Rule environment so we can check its output.
+              :env {:rule-output rule-output-env} ; Rule environment so we can check its output.
               :lhs '[{:args [[e a v]]
                      :type :foo
                      :constraints [(= e 1) (= v ?value)]}]
@@ -1330,7 +1330,23 @@
         (insert [1 :foo 42])
         (fire-rules))
 
-    (is (= 42 @rule-output))))
+    (is (= 42 @rule-output-env))))
+
+(deftest test-destructured-test-env-binding
+  (let [rule-output-env (atom nil)
+        rule {:name "clara.test-destructured-binding/test-destructured-test-env-binding"
+              :env {:rule-output rule-output-env} ; Rule environment so we can check its output.
+              :lhs '[{:args [[e a v]]
+                      :type :foo
+                      :constraints [(= e ?entity) (= v ?value)]}
+                     {:constraints [(= ?entity 1) (reset! rule-output ?value)]}]
+              :rhs '(inc 1)}]
+
+    (-> (mk-session [rule] :fact-type-fn second)
+        (insert [1 :foo 42])
+        (fire-rules))
+
+    (is (= 42 @rule-output-env))))
 
 (def locals-shadowing-tester
   "Used to demonstrate local shadowing works in `test-explicit-rhs-map-can-use-ns-name-for-unqualified-symbols` below."
@@ -2379,7 +2395,7 @@
       (assert-ex-data "Condition exception raised.\nwith no fact\nwith bindings\n  {:?w 10, :?t nil}\nConditions:\n\n1. [:test (> ?t ?w)]\n   queries:\n     my-test-query\n"
                       {:bindings {:?w 10, :?t nil}
                        :fact nil
-                       :env {}
+                       :env nil
                        :conditions-and-rules {[:test '(> ?t ?w)] #{[:query "my-test-query"]}}}
                       (-> (mk-session [check-exception])
                           (insert (->WindSpeed 10 "MCI") (->Temperature nil "MCI"))