diff --git a/.github/workflows/clojure.yml b/.github/workflows/clojure.yml index 925bb7c5..2c335361 100644 --- a/.github/workflows/clojure.yml +++ b/.github/workflows/clojure.yml @@ -2,36 +2,40 @@ name: Clojure CI on: push: - branches: [ "main" ] + branches: + - 'main' pull_request: - branches: [ "main" ] + branches: + - '**' jobs: build: runs-on: ubuntu-latest steps: - - uses: actions/checkout@v3 - - name: Setup Java JDK - uses: actions/setup-java@v1.4.4 + - name: Checkout code + uses: actions/checkout@v3 + - name: Tools setup + uses: jdx/mise-action@v2 with: - # The Java version to make available on the path. Takes a whole or semver Java version, or 1.x syntax (e.g. 1.8 => Java 8.x). Early access versions can be specified in the form of e.g. 14-ea, 14.0.0-ea, or 14.0.0-ea.28 - java-version: 1.8 - - name: Setup Node.js environment - uses: actions/setup-node@v2.5.2 - with: - # Version Spec of the version to use. Examples: 12.x, 10.15.1, >=10.15.0 - node-version: 18.16.0 - - name: Install Puppeteer - run: npm install puppeteer - - name: Install Chrome - run: npx puppeteer browsers install chrome - - name: Install dependencies - run: lein deps + install: true + cache: true + - name: Tools config + run: | + echo "JAVA_HOME=$(mise where java)" >> $GITHUB_ENV + echo "GRAALVM_HOME=$(mise where java)" >> $GITHUB_ENV + echo "$(mise where java)/bin" >> $GITHUB_PATH + gu install native-image - name: Run tests - run: lein test + run: make test + - name: Run coverage tests + run: make test-coverage - name: Run generative tests - run: lein test :generative - - name: Run recent-clj tests - run: lein with-profile dev,recent-clj test + run: make test-generative - name: Run clj-kondo linter - run: lein with-profile dev,recent-clj clj-kondo-lint + run: make lint + - name: Run build jar + run: make build + - name: Run build app + run: | + make build-native + build/clara-test-app this is a test invocation of native app diff --git a/.gitignore b/.gitignore index 70d9775b..9c27ed56 100644 --- a/.gitignore +++ b/.gitignore @@ -1,9 +1,9 @@ +/build /target /lib /classes /checkouts /resources/public/js/* -pom.xml pom.xml.asc *.jar *.class @@ -17,4 +17,5 @@ figwheel_server.log *.iml .clj-kondo .lsp -node_modules/* \ No newline at end of file +.cpcache +node_modules/* diff --git a/.mise.toml b/.mise.toml new file mode 100644 index 00000000..80048e18 --- /dev/null +++ b/.mise.toml @@ -0,0 +1,5 @@ +[plugins] +clojure = "https://github.com/asdf-community/asdf-clojure.git" +[tools] +java = "graalvm-22.3.1+java11" +clojure = "1.11" diff --git a/CHANGELOG.md b/CHANGELOG.md index 7dc9e558..79be25a5 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,7 +1,86 @@ -This is a history of changes to clara-rules. +This is a history of changes to k13labs/clara-rules. -# 0.25.0-SNAPSHOT +# 1.4.0 +* (breaking change) renamed the protocol `IRuleSource/load-rules` to `IClaraSource/load-source`, which can load rules and hierarchies. +* (breaking change) rename `clear-ns-productions!` to `clear-ns-vars!` since now there are ns-installed vars that are not productions. +* update linter config for new macros. +* `defrule` now defines rules as functions with two arities, no args returns the rule map, and 2 args is the compiled RHS. +* `defrule` separator `=>` symbol is now optional when there is no LHS expressions +* `clojure.lang.Fn` now implements `clara.rules.compiler/IClaraSource`, and returns a single rule by invoking the like `(a-rule)`. +* add built-in support to serialize `clojure.lang.Var` so that a rule handler var can be serialized correctly. +* add function `clara.rules.compiler/load-source*` to simplify recursively loading using `IClaraSource/load-source`. +* add `defhierarchy` macro to define hierarchies of facts allowing to easily establish parent/child relationships. +# 1.3.5 +* Update sum accumulator to support default-value, set to 0 if not specified, to avoid NPE during sum. + +# 1.3.4 +* Update CyclicalRulesListener to return the cycles-count value when converted to persistent. + +# 1.3.3 +* Upgrade to clojure 1.11.2 to fix `CVE-2024-22871`, despite not really affecting clara-rules. +* Add clj-kondo linter updates to fix bad docstring expression. + +# 1.3.2 +* Enhance memory add-activations implementation by replacing get/set with compute! + +# 1.3.1 +* Enhance caching performance by more predictable md5 caching and sorting productions + +# 1.3.0 +* Enhance compilation performance by using mutable maps from ham-fisted lib + +# 1.2.0 +* Enhance caching support by adding compile caching using core CacheProtocol + +# 1.1.0 +* Enhance caching support by adding session caching using core CacheProtocol + +# 1.0.2 +* Bump futurama version to 1.0.2 to get enhancements + +# 1.0.1 +* Bump futurama version to 1.0.1 to get enhancements + +# 1.0.0 +* Bump futurama version to first major version +* Initial major release of k13labs/clara-rules + +# 0.9.9 +* Bump futurama version to latest + +# 0.9.8 +* Update to latest async library (futurama) to get fixes for async-reduce + +# 0.9.7 +* Update to latest async library + +# 0.9.6 +* Async enhancements and add engine test with thousands of async rules fired for stress test + +# 0.9.5 +* Update docs and explicit async-future in fire-rules-async + +# 0.9.4 +* Update `futurama` to latest version + +# 0.9.3 +* Implement interruptible sessions using futurama's async-cancel capabilities. +* Add tests for infinite loop runaway sessions which can be interrupted. + +# 0.9.2 +* Update docs and futurama version bump again + +# 0.9.1 +* Update docs and futurama version bump + +# 0.9.0 +* Add parallel support to Node and RHS activation. +* Remove ClojureScript support, general cleanup. +* Refactor engine to support both fire-rules and fire-rules-async +* Replace mutable/transient collections with [ham-fisted](https://github.com/cnuernber/ham-fisted) data structures. + +This is a history of changes to clara-rules prior to forking to k13labs/clara-rules. ### 0.24.0 * uplift to cljs 1.11.132 diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 0cc8cc59..c7404588 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -30,10 +30,10 @@ Thanks. * Open a [pull request][7]. * The pull request will be reviewed by the community and merged by the project committers. -[1]: https://github.com/cerner/clara-rules/issues +[1]: https://github.com/k13labs/clara-rules/issues [2]: http://gun.io/blog/how-to-github-fork-branch-and-pull-request [3]: http://tbaggery.com/2008/04/19/a-note-about-git-commit-messages.html [4]: ./CHANGELOG.md [5]: ./LICENSE [6]: http://gitready.com/advanced/2009/02/10/squashing-commits-with-rebase.html -[7]: https://help.github.com/articles/using-pull-requests \ No newline at end of file +[7]: https://help.github.com/articles/using-pull-requests diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 42c8a21c..dcec17f4 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -1,17 +1,15 @@ -Cerner Corporation +Clara Rules Contributors - Ryan Brush [@rbrush] - Mike Rodriguez [@mrrodriguez] - William Parker [@WilliamParker] - Ethan Christian [@EthanEChristian] - Pushkar Kulkarni [@kulkarnipushkar] - -Community - - David Goeke [@dgoeke] - Dave Dixon [@sparkofreason] - Baptiste Fontaine [@bfontaine] - Jose Gomez [@k13gomez] +- Lucio Assis [@luciolucio] - Imre Kószó [@imrekoszo] [@rbrush]: https://github.com/rbrush @@ -24,4 +22,5 @@ Community [@bfontaine]: https://github.com/bfontaine [@sunilgunisetty]: https://github.com/sunilgunisetty [@k13gomez]: https://github.com/k13gomez +[@luciolucio]: https://github.com/luciolucio [@imrekoszo]: https://github.com/imrekoszo diff --git a/Makefile b/Makefile new file mode 100644 index 00000000..61f436a8 --- /dev/null +++ b/Makefile @@ -0,0 +1,70 @@ +.PHONY: repl test clean compile-main-java compile-test-java deploy install format-check format-fix + +SHELL := /bin/bash + +env: + env + +compile-main-java: + clojure -T:build compile-main-java + +compile-test-java: compile-main-java + clojure -T:build compile-test-java + +repl: compile-test-java + clojure -M:dev:test:app:repl + +test: compile-test-java + clojure -M:dev:test:app:runner --focus :unit --reporter kaocha.report/documentation --no-capture-output + +test-coverage: compile-test-java + clojure -M:dev:test:app:runner --focus :coverage --reporter kaocha.report/documentation --no-capture-output + jq '.coverage["clara/coverage_ruleset.clj"]|join("_")' target/coverage/codecov.json | grep "_1___1____1_0_1__1__" || echo "Unexpected coverage output for clara.coverage-ruleset." exit 1 + +test-generative: compile-test-java + clojure -M:dev:test:app:runner --focus :generative --reporter kaocha.report/documentation --no-capture-output + +test-config: + clojure -M:dev:test:app:runner --print-config + +clean: + rm -rf target build + +lint: compile-test-java + clojure -M:dev:test:app:clj-kondo --copy-configs --dependencies --parallel --lint "$(shell clojure -A:dev:test -Spath)" + clojure -M:dev:test:app:clj-kondo --lint "src/main:src/test" --fail-level "error" + +build: compile-main-java + clojure -X:jar :sync-pom true :jar "build/clara-rules.jar" + +build-native: build + mkdir -p build/graalvm-config + clojure -X:uberjar :sync-pom false :jar "build/clara-test-app.jar" + java -agentlib:native-image-agent=config-output-dir=build/graalvm-config -jar "build/clara-test-app.jar" clara.main + native-image -jar "build/clara-test-app.jar" \ + "-H:+ReportExceptionStackTraces" \ + "-H:+JNI" \ + "-H:EnableURLProtocols=http,https,jar" \ + "-J-Dclojure.spec.skip-macros=true" \ + "-J-Dclojure.compiler.direct-linking=true" \ + "--report-unsupported-elements-at-runtime" \ + "--verbose" \ + "--no-fallback" \ + "--no-server" \ + "--allow-incomplete-classpath" \ + "--trace-object-instantiation=java.lang.Thread" \ + "--features=clj_easy.graal_build_time.InitClojureClasses" \ + "-H:ConfigurationFileDirectories=build/graalvm-config" \ + "build/clara-test-app" + +deploy: clean build + clojure -X:deploy-maven + +install: + clojure -X:install-maven + +format-check: + clojure -M:format-check + +format-fix: + clojure -M:format-fix diff --git a/NOTICE b/NOTICE index cd7fd35c..a83dae24 100644 --- a/NOTICE +++ b/NOTICE @@ -1,4 +1,4 @@ -Copyright 2016 Cerner Innovation, Inc. +Copyright 2023 Jose Gomez Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. diff --git a/README.md b/README.md index 57e42945..4dc4f714 100644 --- a/README.md +++ b/README.md @@ -1,16 +1,19 @@ -[![Build Status](https://github.com/cerner/clara-rules/actions/workflows/clojure.yml/badge.svg)](https://github.com/cerner/clara-rules/actions/workflows/clojure.yml) +[![Build Status](https://github.com/k13labs/clara-rules/actions/workflows/clojure.yml/badge.svg)](https://github.com/k13labs/clara-rules/actions/workflows/clojure.yml) # _About_ Clara is a forward-chaining rules engine written in Clojure(Script) with Java interoperability. It aims to simplify code with a developer-centric approach to expert systems. See [clara-rules.org](http://www.clara-rules.org) for more. +NOTE: this fork only supports the JVM/Clojure, and not ClojureScript. + # _Usage_ Here's a simple example. Complete documentation is at [clara-rules.org](http://www.clara-rules.org/docs/firststeps/). ```clj (ns clara.support-example - (:require [clara.rules :refer :all])) + (:require [clara.rules :refer :all] + [futurama.core :refer [! (println "Notify" ?name "that" ?client "has a new support request!")) -;; Run the rules! We can just use Clojure's threading macro to wire things up. +;; We can just use Clojure's threading macro to wire things up below. + +;; Run the rules! (-> (mk-session) (insert (->ClientRepresentative "Alice" "Acme") (->SupportRequest "Acme" :high)) (fire-rules)) +;; Run the rules asynchronously! +(! (mk-session) + (insert (->ClientRepresentative "Alice" "Acme") + (->SupportRequest "Acme" :high)) + (fire-rules-async {:parallel-batch-size 50}))) + ;;;; Prints this: ;; High support requested! @@ -43,35 +54,41 @@ Here's a simple example. Complete documentation is at [clara-rules.org](http://w # _Building_ -Clara is built, tested, and deployed using [Leiningen](http://leiningen.org). -ClojureScript tests are executed via [puppeteer](https://pptr.dev/). -``` -npm install -g puppeteer -npx puppeteer browsers install chrome -``` +Clara is built, tested, and deployed using [Clojure Tools Deps](https://clojure.org/guides/deps_and_cli). + +GNU Make is used to simplify invocation of some commands. # _Availability_ -Clara releases are on [Clojars](https://clojars.org/). Simply add the following to your project: +Clara releases for this project are on [Clojars](https://clojars.org/). Simply add the following to your project: -[![Clojars Project](http://clojars.org/com.cerner/clara-rules/latest-version.svg)](http://clojars.org/com.cerner/clara-rules) +[![Clojars Project](http://clojars.org/com.github.k13labs/clara-rules/latest-version.svg)](http://clojars.org/com.github.k13labs/clara-rules) # _Communication_ -Questions can be posted to the [Clara Rules Google Group](https://groups.google.com/forum/?hl=en#!forum/clara-rules) or the [Slack channel](https://clojurians.slack.com/messages/clara/). +- Questions about Clara rules can be posted to the [Clara Rules Google Group](https://groups.google.com/forum/?hl=en#!forum/clara-rules) or the [Slack channel](https://clojurians.slack.com/messages/clara/). +- For any other questions or issues about this Clara rules fork specifically feel free to browse or open a [Github Issue](https://github.com/k13labs/clara-rules/issues). # Contributing See [CONTRIBUTING.md](CONTRIBUTING.md) +# YourKit + +[![YourKit](https://www.yourkit.com/images/yklogo.png)](https://www.yourkit.com/) + +YourKit supports open source projects with innovative and intelligent tools +for monitoring and profiling Java and .NET applications. +YourKit is the creator of [YourKit Java Profiler](https://www.yourkit.com/java/profiler/), +[YourKit .NET Profiler](https://www.yourkit.com/dotnet-profiler/), +and [YourKit YouMonitor](https://www.yourkit.com/youmonitor/). + # LICENSE -Copyright 2018 Cerner Innovation, Inc. +Copyright 2023 Jose Gomez Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at     http://www.apache.org/licenses/LICENSE-2.0 Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. - - diff --git a/RELEASE.md b/RELEASE.md index c4b38775..e6fdf787 100644 --- a/RELEASE.md +++ b/RELEASE.md @@ -4,18 +4,15 @@ This project is hosted on [Clojars][clojars]. You can see it [here][release-sit Releasing the project requires these steps: -0. Assert all tests are passing and the project builds : `lein do clean, test` -1. Make sure CHANGELOG.md is up-to-date for the upcoming release. -2. Assert you have Github setup with [gpg](https://docs.github.com/en/authentication/managing-commit-signature-verification/adding-a-gpg-key-to-your-github-account) -3. Add gpg key to [sign](https://git-scm.com/book/en/v2/Git-Tools-Signing-Your-Work) your commits - * GPG will likely require an additional export to spawn an interactive prompt for signing: - ```export GPG_TTY=$(tty)``` -4. Create a [Clojars][clojars] Account and [Deploy Token](https://github.com/clojars/clojars-web/wiki/Deploy-Tokens) if you do not already have one. -5. Create a lein [credentials](https://leiningen.org/deploy.html#gpg) file using the account and token above. -6. Run `lein release `, where release-type is one of `:patch`,`:minor` and `:major` -7. Push the new main branch to the repo. -8. Push the new tag to the repo. +1. Run ```make test``` to ensure everything is working as expected. +2. Set the version number and tag in the `pom.xml` file, commit the changes. +3. Use a GitHub [project release][github-release-url] to release the project and tag (be sure it follows [semver][semantic-versioning]) +4. Run ```make clean build``` to test building the project, commit any changes to the `pom.xml` file. +5. Run ```make deploy``` to deploy the project to the Clojars repository. +6. Update the `pom.xml` in `main` to a new minor version, commit the changes. [clojars]: https://clojars.org -[release-site]: https://clojars.org/com.cerner/clara-rules - +[release-site]: https://clojars.org/com.github.k13labs/clara-rules +[project-url]: https://github.com/k13labs/clara-rules/ +[semantic-versioning]: http://semver.org/ +[github-release-url]: https://help.github.com/articles/creating-releases/ diff --git a/app/clara/main.clj b/app/clara/main.clj new file mode 100644 index 00000000..7b462432 --- /dev/null +++ b/app/clara/main.clj @@ -0,0 +1,51 @@ +(ns clara.main + (:require + [clara.rules :refer [defrule + insert! + insert + defquery + defhierarchy + defsession + query + fire-rules-async] :as r] + [futurama.core :refer [! + (insert! {:fact/type :my/result + :result ?value})) + +(defquery simple-output-query + "simple query that returns an output fact" + [] + [?output <- :my/output]) + +(defhierarchy simple-hierarchy + "simple hierarchy of facts" + :my/thing :my/input + :my/result :my/output + :my/input :my/fact + :my/output :my/fact) + +(defsession my-session + 'clara.main + :fact-type-fn :fact/type) + +(defn -main + "this is a test to compile a bunch of async code into native code, pretty nasty" + [& args] + (println + "async result:" + (! my-session + (insert {:fact/type :my/thing + :value args}) + (fire-rules-async)))] + (query session simple-output-query)))))) diff --git a/bin/kaocha b/bin/kaocha new file mode 100755 index 00000000..4c19821a --- /dev/null +++ b/bin/kaocha @@ -0,0 +1,2 @@ +#!/usr/bin/env bash +clojure -M:dev:test:runner $@ diff --git a/clj-kondo/clj-kondo.exports/clara/rules/config.edn b/clj-kondo/clj-kondo.exports/clara/rules/config.edn index 6b946f6a..a69f1a16 100644 --- a/clj-kondo/clj-kondo.exports/clara/rules/config.edn +++ b/clj-kondo/clj-kondo.exports/clara/rules/config.edn @@ -1,7 +1,9 @@ {:lint-as {clara.rules/defsession clojure.core/def - clara.rules.platform/eager-for clojure.core/for} + clara.rules.platform/eager-for clojure.core/for + clara.rules.platform/compute-for clojure.core/for} :hooks {:analyze-call {clara.rules/defquery hooks.clara-rules/analyze-defquery-macro clara.rules/defrule hooks.clara-rules/analyze-defrule-macro + clara.rules/defhierarchy hooks.clara-rules/analyze-defhierarchy-macro clara.rules.dsl/parse-query hooks.clara-rules/analyze-parse-query-macro clara.rules.dsl/parse-rule hooks.clara-rules/analyze-parse-rule-macro clara.tools.testing-utils/def-rules-test hooks.clara-rules/analyze-def-rules-test-macro}}} diff --git a/clj-kondo/clj-kondo.exports/clara/rules/hooks/clara_rules.clj_kondo b/clj-kondo/clj-kondo.exports/clara/rules/hooks/clara_rules.clj_kondo index 0d5abbcc..4b34ba78 100644 --- a/clj-kondo/clj-kondo.exports/clara/rules/hooks/clara_rules.clj_kondo +++ b/clj-kondo/clj-kondo.exports/clara/rules/hooks/clara_rules.clj_kondo @@ -112,15 +112,15 @@ (if binding-nodes [next-bindings-set (cond->> [[(api/vector-node - (vec binding-nodes)) + (vec binding-nodes)) constraint-expr]] binding-expr-nodes (concat [[(api/vector-node - (vec binding-expr-nodes)) + (vec binding-expr-nodes)) input-token]]))] [#{} [[(api/vector-node - [(api/token-node '_)]) + [(api/token-node '_)]) constraint-expr]]])] (recur more (concat bindings next-bindings) @@ -143,11 +143,11 @@ (let [condition (:children condition-expr) [result-token fact-node & condition] (if (= '<- (-> condition second node-value)) (cons (api/vector-node - [(vary-meta - (first condition) - assoc ::fact-result true)]) (nnext condition)) + [(vary-meta + (first condition) + assoc ::fact-result true)]) (nnext condition)) (cons (api/vector-node - [(api/token-node '_)]) condition)) + [(api/token-node '_)]) condition)) condition-bindings (cond (nil? condition) [] @@ -174,20 +174,20 @@ (set) (sort-by node-value)) output-node (api/vector-node - (if (empty? condition-output) - [(api/token-node '_)] - (vec condition-output))) + (if (empty? condition-output) + [(api/token-node '_)] + (vec condition-output))) output-result-node (api/vector-node - (if (empty? condition-output) - [(api/token-node nil)] - (vec condition-output))) + (if (empty? condition-output) + [(api/token-node nil)] + (vec condition-output))) next-bindings [output-node (api/list-node - (list - (api/token-node 'let) - (api/vector-node - (vec (apply concat output-bindings))) - output-result-node))]] + (list + (api/token-node 'let) + (api/vector-node + (vec (apply concat output-bindings))) + output-result-node))]] (recur more (concat bindings [next-bindings])))))) (defn analyze-parse-query-macro @@ -195,22 +195,22 @@ [{:keys [:node]}] (let [input-token (api/token-node (gensym 'input)) input-args (api/vector-node - [input-token]) + [input-token]) [args conditions-node] (rest (:children node)) condition-seq (:children conditions-node) special-tokens (extract-special-tokens condition-seq) special-args (when (seq special-tokens) (api/vector-node - (vec special-tokens))) + (vec special-tokens))) transformed-args (for [arg (:children args)] (let [v (node-value arg)] (if (keyword? v) (api/token-node (symbol v)) arg))) production-args (api/vector-node - (if (empty? transformed-args) - [(api/token-node '_)] - (vec transformed-args))) + (if (empty? transformed-args) + [(api/token-node '_)] + (vec transformed-args))) condition-bindings (analyze-conditions condition-seq true [] input-token production-args) production-bindings (apply concat (when special-args @@ -223,19 +223,20 @@ (set) (sort-by node-value)) production-result (api/list-node - (list - (api/token-node 'let) - (api/vector-node - (vec production-bindings)) - (api/vector-node - (vec production-output)))) + (list + (api/token-node 'let) + (api/vector-node + (vec production-bindings)) + (api/vector-node + (vec production-output)))) fn-node (api/list-node - (list - (api/token-node 'fn) - input-args - production-result)) + (list + (api/token-node 'fn) + (api/token-node 'query-fn) + input-args + production-result)) new-node (api/map-node - [(api/keyword-node :production) fn-node])] + [(api/keyword-node :production) fn-node])] {:node new-node})) (defn analyze-defquery-macro @@ -249,12 +250,12 @@ (first children)) input-token (api/token-node (gensym 'input)) input-args (api/vector-node - [input-token]) + [input-token]) [args & condition-seq] (if production-opts (rest children) children) special-tokens (extract-special-tokens condition-seq) special-args (when (seq special-tokens) (api/vector-node - (vec special-tokens))) + (vec special-tokens))) transformed-args (for [arg (:children args)] (let [v (node-value arg) m (meta arg)] @@ -264,9 +265,9 @@ (vary-meta merge m)) arg))) production-args (api/vector-node - (if (empty? transformed-args) - [(api/token-node '_)] - (vec transformed-args))) + (if (empty? transformed-args) + [(api/token-node '_)] + (vec transformed-args))) condition-bindings (analyze-conditions condition-seq true [] input-token production-args) production-bindings (apply concat (when special-args @@ -279,25 +280,25 @@ (set) (sort-by node-value)) production-result (api/list-node - (list - (api/token-node 'let) - (api/vector-node - (vec production-bindings)) - (api/vector-node - (vec production-output)))) + (list + (api/token-node 'let) + (api/vector-node + (vec production-bindings)) + (api/vector-node + (vec production-output)))) fn-node (api/list-node - (cond-> (list (api/token-node 'fn)) - production-docs (concat [production-docs]) - :always (concat [input-args]) - production-opts (concat [production-opts]) - :always (concat [production-result]))) + (cond-> (list (api/token-node 'fn) production-name) + production-docs (concat [production-docs]) + :always (concat [input-args]) + production-opts (concat [production-opts]) + :always (concat [production-result]))) new-node (vary-meta - (api/list-node - (list - (api/token-node 'def) production-name - (api/map-node - [(api/keyword-node :production) fn-node]))) - merge {:clj-kondo/ignore [:clojure-lsp/unused-public-var]})] + (api/list-node + (list + (api/token-node 'def) production-name + (api/map-node + [(api/keyword-node :production) fn-node]))) + merge {:clj-kondo/ignore [:clojure-lsp/unused-public-var]})] {:node new-node})) (defn analyze-parse-rule-macro @@ -305,13 +306,13 @@ [{:keys [:node]}] (let [input-token (api/token-node (gensym 'input)) input-args (api/vector-node - [input-token]) + [input-token]) empty-args (api/vector-node []) production-seq (rest (:children node)) special-tokens (extract-special-tokens production-seq) special-args (when (seq special-tokens) (api/vector-node - (vec special-tokens))) + (vec special-tokens))) [conditions-node body-node] production-seq condition-seq (:children conditions-node) condition-bindings (analyze-conditions condition-seq true [] input-token empty-args) @@ -327,20 +328,21 @@ (set) (sort-by node-value)) production-result (api/list-node - (list - (api/token-node 'let) - (api/vector-node - (vec production-bindings)) - (api/vector-node - (vec production-output)) - body-node)) + (list + (api/token-node 'let) + (api/vector-node + (vec production-bindings)) + (api/vector-node + (vec production-output)) + body-node)) fn-node (api/list-node - (list - (api/token-node 'fn) - input-args - production-result)) + (list + (api/token-node 'fn) + (api/token-node 'rule-fn) + input-args + production-result)) new-node (api/map-node - [(api/keyword-node :production) fn-node])] + [(api/keyword-node :production) fn-node])] {:node new-node})) (defn analyze-defrule-macro @@ -354,13 +356,13 @@ (first children)) input-token (api/token-node (gensym 'input)) input-args (api/vector-node - [input-token]) + [input-token]) empty-args (api/vector-node []) production-seq (if production-opts (rest children) children) special-tokens (extract-special-tokens production-seq) special-args (when (seq special-tokens) (api/vector-node - (vec special-tokens))) + (vec special-tokens))) [body-seq _ condition-seq] (->> (partition-by (comp #{'=>} node-value) production-seq) (reverse)) condition-bindings (analyze-conditions condition-seq true [] input-token empty-args) @@ -376,28 +378,41 @@ (set) (sort-by node-value)) production-result (api/list-node - (list* - (api/token-node 'let) - (api/vector-node - (vec production-bindings)) - (api/vector-node - (vec production-output)) - body-seq)) + (list* + (api/token-node 'let) + (api/vector-node + (vec production-bindings)) + (api/vector-node + (vec production-output)) + body-seq)) fn-node (api/list-node - (cond-> (list (api/token-node 'fn)) - production-docs (concat [production-docs]) - :always (concat [input-args]) - production-opts (concat [production-opts]) - :always (concat [production-result]))) + (cond-> (list (api/token-node 'fn) production-name) + production-docs (concat [production-docs]) + :always (concat [input-args]) + production-opts (concat [production-opts]) + :always (concat [production-result]))) new-node (vary-meta - (api/list-node - (list - (api/token-node 'def) production-name - (api/map-node - [(api/keyword-node :production) fn-node]))) - merge {:clj-kondo/ignore [:clojure-lsp/unused-public-var]})] + (api/list-node + (list + (api/token-node 'def) production-name + (api/map-node + [(api/keyword-node :production) fn-node]))) + merge {:clj-kondo/ignore [:clojure-lsp/unused-public-var]})] {:node new-node})) +(defn analyze-defhierarchy-macro + "analyze clara-rules defhierarchy macro" + [{:keys [:node]}] + (let [[var-name & children] (rest (:children node)) + new-node (vary-meta + (api/list-node + (list + (api/token-node 'def) + var-name + (api/vector-node + children))) + merge {:clj-kondo/ignore [:clojure-lsp/unused-public-var]})] + {:node new-node})) (defn analyze-def-rules-test-macro [{:keys [:node]}] @@ -410,35 +425,35 @@ (into {})) rules-seq (for [[name-node rule-node] (partition 2 (:children rules))] [name-node (analyze-parse-rule-macro - {:node (api/list-node - (list* - (api/token-node 'clara.rules.dsl/parse-rule) - (:children rule-node)))})]) + {:node (api/list-node + (list* + (api/token-node 'clara.rules.dsl/parse-rule) + (:children rule-node)))})]) query-seq (for [[name-node query-node] (partition 2 (:children queries))] [name-node (analyze-parse-query-macro - {:node (api/list-node - (list* - (api/token-node 'clara.rules.dsl/parse-query) - (:children query-node)))})]) + {:node (api/list-node + (list* + (api/token-node 'clara.rules.dsl/parse-query) + (:children query-node)))})]) session-seq (for [[name-node productions-node options-node] (partition 3 (:children sessions)) :let [args-seq (concat (:children productions-node) (:children options-node))]] [name-node (api/list-node - (list - (api/token-node 'clara.rules.compiler/mk-session) - (api/vector-node - (vec args-seq))))]) + (list + (api/token-node 'clara.rules.compiler/mk-session) + (api/vector-node + (vec args-seq))))]) args-seq (->> (concat rules-seq query-seq session-seq) (apply concat)) wrap-body (api/list-node - (list* - (api/token-node 'let) - (api/vector-node - (vec args-seq)) - test-body)) + (list* + (api/token-node 'let) + (api/vector-node + (vec args-seq)) + test-body)) new-node (api/list-node - (list - (api/token-node 'clojure.test/deftest) - test-name - wrap-body))] + (list + (api/token-node 'clojure.test/deftest) + test-name + wrap-body))] {:node new-node})) diff --git a/deps.edn b/deps.edn new file mode 100644 index 00000000..0a3eaf7d --- /dev/null +++ b/deps.edn @@ -0,0 +1,72 @@ +{:paths ["src/main/clojure" "resources" "clj-kondo" "target/main/classes"] + :deps/prep-lib {:alias :build + :fn compile-main-java + :ensure "target/main/classes"} + :deps {org.clojure/clojure {:mvn/version "1.11.4"} + org.clojure/core.cache {:mvn/version "1.1.234"} + com.github.k13labs/futurama {:mvn/version "1.0.3"} + com.cnuernber/ham-fisted {:mvn/version "2.017"} + prismatic/schema {:mvn/version "1.4.1"} + org.clojure/data.fressian {:mvn/version "1.1.0"}} + + ;for more examples of aliases see: https://github.com/seancorfield/dot-clojure + :aliases + {:build {:paths ["tool"] + :deps {io.github.clojure/tools.build {:mvn/version "0.10.5"}} + :ns-default build} + :dev {:extra-paths ["dev"] + :extra-deps {reloaded.repl/reloaded.repl {:mvn/version "0.2.4"} + org.clojure/math.combinatorics {:mvn/version "0.3.0"} + criterium/criterium {:mvn/version "0.4.6"}}} + + :app {:extra-paths ["app"] + :extra-deps {com.github.clj-easy/graal-build-time {:mvn/version "1.0.5"}}} + + :clj-kondo {:extra-deps {clj-kondo/clj-kondo {:mvn/version "2024.03.05"}} + :main-opts ["-m" "clj-kondo.main"]} + + :test {:extra-paths ["src/test/clojure" "target/test/classes"] + :extra-deps {lambdaisland/kaocha {:mvn/version "1.91.1392"} + lambdaisland/kaocha-junit-xml {:mvn/version "1.17.101"} + lambdaisland/kaocha-cloverage {:mvn/version "1.1.89"} + org.clojure/test.check {:mvn/version "1.1.1"} + pjstadig/humane-test-output {:mvn/version "0.11.0"}}} + + :runner {:main-opts ["-e" "(println \"warn-on-reflection =\" (set! *warn-on-reflection* true))" + "-m" "kaocha.runner"] + :exec-fn kaocha.runner/exec-fn} + + + :repl {:extra-deps {nrepl/nrepl {:mvn/version "1.3.0"} + cider/cider-nrepl {:mvn/version "0.50.1"}} + :main-opts ["-e" "(println \"warn-on-reflection =\" (set! *warn-on-reflection* true))" + "-m" "nrepl.cmdline" "--interactive" + "--middleware" "[\"cider.nrepl/cider-middleware\"]"]} + + :format-fix {:extra-deps {cljfmt/cljfmt {:mvn/version "0.9.2"}} + :main-opts ["-m" "cljfmt.main" "fix" "src" "dev"]} + + :format-check {:extra-deps {cljfmt/cljfmt {:mvn/version "0.9.2"}} + :main-opts ["-m" "cljfmt.main" "check" "src" "dev"]} + + :jar {:replace-deps {com.github.seancorfield/depstar {:mvn/version "2.1.303"}} + :exec-fn hf.depstar/jar} + + :uberjar {:replace-deps {com.github.seancorfield/depstar {:mvn/version "2.1.303"}} + :exec-fn hf.depstar/uberjar + :exec-args {:aot true + :aliases [:app] + :main-class clara.main}} + + :install-maven {:extra-deps {slipset/deps-deploy {:mvn/version "0.2.2"}} + :exec-fn deps-deploy.deps-deploy/deploy + :exec-args {:installer :local + :artifact "build/clara-rules.jar"}} + + :deploy-maven {:replace-deps {slipset/deps-deploy {:mvn/version "0.2.2"}} + :exec-fn deps-deploy.deps-deploy/deploy + :exec-args {:installer :remote + :artifact "build/clara-rules.jar"}}} + :mvn/repos + {"central" {:url "https://repo1.maven.org/maven2/"} + "clojars" {:url "https://repo.clojars.org/"}}} diff --git a/dev/user.clj b/dev/user.clj new file mode 100644 index 00000000..8e5881d2 --- /dev/null +++ b/dev/user.clj @@ -0,0 +1,118 @@ +(ns user + (:require [criterium.core :refer [report-result + quick-benchmark + with-progress-reporting] :as crit] + [clara.rules :refer [defrule defquery defhierarchy + insert! insert-all! + insert insert-all + fire-rules + query + mk-session + clear-ns-vars!]] + [clojure.core.cache.wrapped :as cache])) + +(comment + (clear-ns-vars!) + (add-tap #'println) + (remove-tap #'println) + (tap> "foobar")) + +(defhierarchy foobar + :thing/foo :thing/that + :thing/bar :thing/that) + +(defrule return-a-thing + [:thing/that [{:keys [value]}] (= value ?value)] + => + (insert! {:type :thing/result + :value ?value})) + +(defquery query-a-thing + [] + [?output <- :thing/result]) + +(defrule default-data + (insert-all! + [{:type :thing/foo + :value 1} + {:type :thing/bar + :value 2} + {:type :thing/bar + :value 3}])) + +(comment + (time + (-> (mk-session 'user :fact-type-fn :type) + (fire-rules) + (query query-a-thing)))) + +(def session-cache + (cache/lru-cache-factory {})) + +;; Cache of compiled expressions +(def compiler-cache + (cache/soft-cache-factory {})) + +(defmacro mk-types + [n] + (let [facts (for [n (range n)] + {:fact-type {:t (symbol (format "FactType%s" n)) + :c (symbol (format "%s.FactType%s" (ns-name *ns*) n))} + :fact-record {:t (symbol (format "FactRecord%s" n)) + :c (symbol (format "%s.FactRecord%s" (ns-name *ns*) n))}}) + type-declarations (for [{{:keys [t]} :fact-type} facts] + `(deftype ~t [])) + record-declarations (for [{{:keys [t]} :fact-record} facts] + `(defrecord ~t []))] + `(do + ~@type-declarations + ~@record-declarations))) + +(defmacro mk-rules + [n] + (let [facts (for [n (range n)] + {:decl-name (symbol (format "rule-%s" n)) + :fact-type {:t (symbol (format "FactType%s" n)) + :c (symbol (format "%s.FactType%s" (ns-name *ns*) n))} + :fact-record {:t (symbol (format "FactRecord%s" n)) + :c (symbol (format "%s.FactRecord%s" (ns-name *ns*) n))}}) + fact-rules (for [{:keys [fact-type + fact-record]} facts] + `(hash-map + :ns-name (ns-name *ns*) + :lhs [{:type ~(:c fact-type) + :constraints []} + {:type ~(:c fact-record) + :constraints []}] + :rhs '(println (str "class:" ~n ~fact-type ~fact-record)))) + decl-rules (for [{:keys [decl-name + fact-type + fact-record]} facts] + `(defrule ~decl-name + [~(:c fact-type)] + [~(:c fact-record)] + => + (println (str "class:" ~n ~fact-type ~fact-record))))] + `(do + ~@decl-rules + (vector + ~@fact-rules)))) + +(comment + (clear-ns-vars!) + (mk-types 2500) + (def rules + (mk-rules 2500)) + (keys @session-cache) + (when-let [v (first (.cache ^clojure.core.cache.SoftCache @compiler-cache))] + (.getValue v)) + (count @session-cache) + (count (.cache ^clojure.core.cache.SoftCache @compiler-cache)) + + (time + (mk-session 'user [(conj rules {:ns-name (ns-name *ns*) + :lhs [{:type :foobar1 + :constraints []}] + :rhs `(println ~(str :foobar))})] + :cache session-cache + :compiler-cache compiler-cache))) diff --git a/package-lock.json b/package-lock.json deleted file mode 100644 index 7d08023c..00000000 --- a/package-lock.json +++ /dev/null @@ -1,1326 +0,0 @@ -{ - "name": "clara-rules", - "lockfileVersion": 3, - "requires": true, - "packages": { - "": { - "devDependencies": { - "puppeteer": "^22.11.2" - } - }, - "node_modules/@babel/code-frame": { - "version": "7.24.2", - "resolved": "https://registry.npmjs.org/@babel/code-frame/-/code-frame-7.24.2.tgz", - "integrity": "sha512-y5+tLQyV8pg3fsiln67BVLD1P13Eg4lh5RW9mF0zUuvLrv9uIQ4MCL+CRT+FTsBlBjcIan6PGsLcBN0m3ClUyQ==", - "dev": true, - "dependencies": { - "@babel/highlight": "^7.24.2", - "picocolors": "^1.0.0" - }, - "engines": { - "node": ">=6.9.0" - } - }, - "node_modules/@babel/helper-validator-identifier": { - "version": "7.22.20", - "resolved": "https://registry.npmjs.org/@babel/helper-validator-identifier/-/helper-validator-identifier-7.22.20.tgz", - "integrity": "sha512-Y4OZ+ytlatR8AI+8KZfKuL5urKp7qey08ha31L8b3BwewJAoJamTzyvxPR/5D+KkdJCGPq/+8TukHBlY10FX9A==", - "dev": true, - "engines": { - "node": ">=6.9.0" - } - }, - "node_modules/@babel/highlight": { - "version": "7.24.2", - "resolved": "https://registry.npmjs.org/@babel/highlight/-/highlight-7.24.2.tgz", - "integrity": "sha512-Yac1ao4flkTxTteCDZLEvdxg2fZfz1v8M4QpaGypq/WPDqg3ijHYbDfs+LG5hvzSoqaSZ9/Z9lKSP3CjZjv+pA==", - "dev": true, - "dependencies": { - "@babel/helper-validator-identifier": "^7.22.20", - "chalk": "^2.4.2", - "js-tokens": "^4.0.0", - "picocolors": "^1.0.0" - }, - "engines": { - "node": ">=6.9.0" - } - }, - "node_modules/@puppeteer/browsers": { - "version": "2.2.3", - "resolved": "https://registry.npmjs.org/@puppeteer/browsers/-/browsers-2.2.3.tgz", - "integrity": "sha512-bJ0UBsk0ESOs6RFcLXOt99a3yTDcOKlzfjad+rhFwdaG1Lu/Wzq58GHYCDTlZ9z6mldf4g+NTb+TXEfe0PpnsQ==", - "dev": true, - "dependencies": { - "debug": "4.3.4", - "extract-zip": "2.0.1", - "progress": "2.0.3", - "proxy-agent": "6.4.0", - "semver": "7.6.0", - "tar-fs": "3.0.5", - "unbzip2-stream": "1.4.3", - "yargs": "17.7.2" - }, - "bin": { - "browsers": "lib/cjs/main-cli.js" - }, - "engines": { - "node": ">=18" - } - }, - "node_modules/@tootallnate/quickjs-emscripten": { - "version": "0.23.0", - "resolved": "https://registry.npmjs.org/@tootallnate/quickjs-emscripten/-/quickjs-emscripten-0.23.0.tgz", - "integrity": "sha512-C5Mc6rdnsaJDjO3UpGW/CQTHtCKaYlScZTly4JIu97Jxo/odCiH0ITnDXSJPTOrEKk/ycSZ0AOgTmkDtkOsvIA==", - "dev": true - }, - "node_modules/@types/node": { - "version": "20.14.5", - "resolved": "https://registry.npmjs.org/@types/node/-/node-20.14.5.tgz", - "integrity": "sha512-aoRR+fJkZT2l0aGOJhuA8frnCSoNX6W7U2mpNq63+BxBIj5BQFt8rHy627kijCmm63ijdSdwvGgpUsU6MBsZZA==", - "dev": true, - "optional": true, - "dependencies": { - "undici-types": "~5.26.4" - } - }, - "node_modules/@types/yauzl": { - "version": "2.10.3", - "resolved": "https://registry.npmjs.org/@types/yauzl/-/yauzl-2.10.3.tgz", - "integrity": "sha512-oJoftv0LSuaDZE3Le4DbKX+KS9G36NzOeSap90UIK0yMA/NhKJhqlSGtNDORNRaIbQfzjXDrQa0ytJ6mNRGz/Q==", - "dev": true, - "optional": true, - "dependencies": { - "@types/node": "*" - } - }, - "node_modules/agent-base": { - "version": "7.1.1", - "resolved": "https://registry.npmjs.org/agent-base/-/agent-base-7.1.1.tgz", - "integrity": "sha512-H0TSyFNDMomMNJQBn8wFV5YC/2eJ+VXECwOadZJT554xP6cODZHPX3H9QMQECxvrgiSOP1pHjy1sMWQVYJOUOA==", - "dev": true, - "dependencies": { - "debug": "^4.3.4" - }, - "engines": { - "node": ">= 14" - } - }, - "node_modules/ansi-regex": { - "version": "5.0.1", - "resolved": "https://registry.npmjs.org/ansi-regex/-/ansi-regex-5.0.1.tgz", - "integrity": "sha512-quJQXlTSUGL2LH9SUXo8VwsY4soanhgo6LNSm84E1LBcE8s3O0wpdiRzyR9z/ZZJMlMWv37qOOb9pdJlMUEKFQ==", - "dev": true, - "engines": { - "node": ">=8" - } - }, - "node_modules/ansi-styles": { - "version": "3.2.1", - "resolved": "https://registry.npmjs.org/ansi-styles/-/ansi-styles-3.2.1.tgz", - "integrity": "sha512-VT0ZI6kZRdTh8YyJw3SMbYm/u+NqfsAxEpWO0Pf9sq8/e94WxxOpPKx9FR1FlyCtOVDNOQ+8ntlqFxiRc+r5qA==", - "dev": true, - "dependencies": { - "color-convert": "^1.9.0" - }, - "engines": { - "node": ">=4" - } - }, - "node_modules/argparse": { - "version": "2.0.1", - "resolved": "https://registry.npmjs.org/argparse/-/argparse-2.0.1.tgz", - "integrity": "sha512-8+9WqebbFzpX9OR+Wa6O29asIogeRMzcGtAINdpMHHyAg10f05aSFVBbcEqGf/PXw1EjAZ+q2/bEBg3DvurK3Q==", - "dev": true - }, - "node_modules/ast-types": { - "version": "0.13.4", - "resolved": "https://registry.npmjs.org/ast-types/-/ast-types-0.13.4.tgz", - "integrity": "sha512-x1FCFnFifvYDDzTaLII71vG5uvDwgtmDTEVWAxrgeiR8VjMONcCXJx7E+USjDtHlwFmt9MysbqgF9b9Vjr6w+w==", - "dev": true, - "dependencies": { - "tslib": "^2.0.1" - }, - "engines": { - "node": ">=4" - } - }, - "node_modules/b4a": { - "version": "1.6.6", - "resolved": "https://registry.npmjs.org/b4a/-/b4a-1.6.6.tgz", - "integrity": "sha512-5Tk1HLk6b6ctmjIkAcU/Ujv/1WqiDl0F0JdRCR80VsOcUlHcu7pWeWRlOqQLHfDEsVx9YH/aif5AG4ehoCtTmg==", - "dev": true - }, - "node_modules/bare-events": { - "version": "2.4.2", - "resolved": "https://registry.npmjs.org/bare-events/-/bare-events-2.4.2.tgz", - "integrity": "sha512-qMKFd2qG/36aA4GwvKq8MxnPgCQAmBWmSyLWsJcbn8v03wvIPQ/hG1Ms8bPzndZxMDoHpxez5VOS+gC9Yi24/Q==", - "dev": true, - "optional": true - }, - "node_modules/bare-fs": { - "version": "2.3.1", - "resolved": "https://registry.npmjs.org/bare-fs/-/bare-fs-2.3.1.tgz", - "integrity": "sha512-W/Hfxc/6VehXlsgFtbB5B4xFcsCl+pAh30cYhoFyXErf6oGrwjh8SwiPAdHgpmWonKuYpZgGywN0SXt7dgsADA==", - "dev": true, - "optional": true, - "dependencies": { - "bare-events": "^2.0.0", - "bare-path": "^2.0.0", - "bare-stream": "^2.0.0" - } - }, - "node_modules/bare-os": { - "version": "2.4.0", - "resolved": "https://registry.npmjs.org/bare-os/-/bare-os-2.4.0.tgz", - "integrity": "sha512-v8DTT08AS/G0F9xrhyLtepoo9EJBJ85FRSMbu1pQUlAf6A8T0tEEQGMVObWeqpjhSPXsE0VGlluFBJu2fdoTNg==", - "dev": true, - "optional": true - }, - "node_modules/bare-path": { - "version": "2.1.3", - "resolved": "https://registry.npmjs.org/bare-path/-/bare-path-2.1.3.tgz", - "integrity": "sha512-lh/eITfU8hrj9Ru5quUp0Io1kJWIk1bTjzo7JH1P5dWmQ2EL4hFUlfI8FonAhSlgIfhn63p84CDY/x+PisgcXA==", - "dev": true, - "optional": true, - "dependencies": { - "bare-os": "^2.1.0" - } - }, - "node_modules/bare-stream": { - "version": "2.1.3", - "resolved": "https://registry.npmjs.org/bare-stream/-/bare-stream-2.1.3.tgz", - "integrity": "sha512-tiDAH9H/kP+tvNO5sczyn9ZAA7utrSMobyDchsnyyXBuUe2FSQWbxhtuHB8jwpHYYevVo2UJpcmvvjrbHboUUQ==", - "dev": true, - "optional": true, - "dependencies": { - "streamx": "^2.18.0" - } - }, - "node_modules/base64-js": { - "version": "1.5.1", - "resolved": "https://registry.npmjs.org/base64-js/-/base64-js-1.5.1.tgz", - "integrity": "sha512-AKpaYlHn8t4SVbOHCy+b5+KKgvR4vrsD8vbvrbiQJps7fKDTkjkDry6ji0rUJjC0kzbNePLwzxq8iypo41qeWA==", - "dev": true, - "funding": [ - { - "type": "github", - "url": "https://github.com/sponsors/feross" - }, - { - "type": "patreon", - "url": "https://www.patreon.com/feross" - }, - { - "type": "consulting", - "url": "https://feross.org/support" - } - ] - }, - "node_modules/basic-ftp": { - "version": "5.0.5", - "resolved": "https://registry.npmjs.org/basic-ftp/-/basic-ftp-5.0.5.tgz", - "integrity": "sha512-4Bcg1P8xhUuqcii/S0Z9wiHIrQVPMermM1any+MX5GeGD7faD3/msQUDGLol9wOcz4/jbg/WJnGqoJF6LiBdtg==", - "dev": true, - "engines": { - "node": ">=10.0.0" - } - }, - "node_modules/buffer": { - "version": "5.7.1", - "resolved": "https://registry.npmjs.org/buffer/-/buffer-5.7.1.tgz", - "integrity": "sha512-EHcyIPBQ4BSGlvjB16k5KgAJ27CIsHY/2JBmCRReo48y9rQ3MaUzWX3KVlBa4U7MyX02HdVj0K7C3WaB3ju7FQ==", - "dev": true, - "funding": [ - { - "type": "github", - "url": "https://github.com/sponsors/feross" - }, - { - "type": "patreon", - "url": "https://www.patreon.com/feross" - }, - { - "type": "consulting", - "url": "https://feross.org/support" - } - ], - "dependencies": { - "base64-js": "^1.3.1", - "ieee754": "^1.1.13" - } - }, - "node_modules/buffer-crc32": { - "version": "0.2.13", - "resolved": "https://registry.npmjs.org/buffer-crc32/-/buffer-crc32-0.2.13.tgz", - "integrity": "sha512-VO9Ht/+p3SN7SKWqcrgEzjGbRSJYTx+Q1pTQC0wrWqHx0vpJraQ6GtHx8tvcg1rlK1byhU5gccxgOgj7B0TDkQ==", - "dev": true, - "engines": { - "node": "*" - } - }, - "node_modules/callsites": { - "version": "3.1.0", - "resolved": "https://registry.npmjs.org/callsites/-/callsites-3.1.0.tgz", - "integrity": "sha512-P8BjAsXvZS+VIDUI11hHCQEv74YT67YUi5JJFNWIqL235sBmjX4+qx9Muvls5ivyNENctx46xQLQ3aTuE7ssaQ==", - "dev": true, - "engines": { - "node": ">=6" - } - }, - "node_modules/chalk": { - "version": "2.4.2", - "resolved": "https://registry.npmjs.org/chalk/-/chalk-2.4.2.tgz", - "integrity": "sha512-Mti+f9lpJNcwF4tWV8/OrTTtF1gZi+f8FqlyAdouralcFWFQWF2+NgCHShjkCb+IFBLq9buZwE1xckQU4peSuQ==", - "dev": true, - "dependencies": { - "ansi-styles": "^3.2.1", - "escape-string-regexp": "^1.0.5", - "supports-color": "^5.3.0" - }, - "engines": { - "node": ">=4" - } - }, - "node_modules/chromium-bidi": { - "version": "0.5.23", - "resolved": "https://registry.npmjs.org/chromium-bidi/-/chromium-bidi-0.5.23.tgz", - "integrity": "sha512-1o/gLU9wDqbN5nL2MtfjykjOuighGXc3/hnWueO1haiEoFgX8h5vbvcA4tgdQfjw1mkZ1OEF4x/+HVeqEX6NoA==", - "dev": true, - "dependencies": { - "mitt": "3.0.1", - "urlpattern-polyfill": "10.0.0", - "zod": "3.23.8" - }, - "peerDependencies": { - "devtools-protocol": "*" - } - }, - "node_modules/cliui": { - "version": "8.0.1", - "resolved": "https://registry.npmjs.org/cliui/-/cliui-8.0.1.tgz", - "integrity": "sha512-BSeNnyus75C4//NQ9gQt1/csTXyo/8Sb+afLAkzAptFuMsod9HFokGNudZpi/oQV73hnVK+sR+5PVRMd+Dr7YQ==", - "dev": true, - "dependencies": { - "string-width": "^4.2.0", - "strip-ansi": "^6.0.1", - "wrap-ansi": "^7.0.0" - }, - "engines": { - "node": ">=12" - } - }, - "node_modules/color-convert": { - "version": "1.9.3", - "resolved": "https://registry.npmjs.org/color-convert/-/color-convert-1.9.3.tgz", - "integrity": "sha512-QfAUtd+vFdAtFQcC8CCyYt1fYWxSqAiK2cSD6zDB8N3cpsEBAvRxp9zOGg6G/SHHJYAT88/az/IuDGALsNVbGg==", - "dev": true, - "dependencies": { - "color-name": "1.1.3" - } - }, - "node_modules/color-name": { - "version": "1.1.3", - "resolved": "https://registry.npmjs.org/color-name/-/color-name-1.1.3.tgz", - "integrity": "sha512-72fSenhMw2HZMTVHeCA9KCmpEIbzWiQsjN+BHcBbS9vr1mtt+vJjPdksIBNUmKAW8TFUDPJK5SUU3QhE9NEXDw==", - "dev": true - }, - "node_modules/cosmiconfig": { - "version": "9.0.0", - "resolved": "https://registry.npmjs.org/cosmiconfig/-/cosmiconfig-9.0.0.tgz", - "integrity": "sha512-itvL5h8RETACmOTFc4UfIyB2RfEHi71Ax6E/PivVxq9NseKbOWpeyHEOIbmAw1rs8Ak0VursQNww7lf7YtUwzg==", - "dev": true, - "dependencies": { - "env-paths": "^2.2.1", - "import-fresh": "^3.3.0", - "js-yaml": "^4.1.0", - "parse-json": "^5.2.0" - }, - "engines": { - "node": ">=14" - }, - "funding": { - "url": "https://github.com/sponsors/d-fischer" - }, - "peerDependencies": { - "typescript": ">=4.9.5" - }, - "peerDependenciesMeta": { - "typescript": { - "optional": true - } - } - }, - "node_modules/data-uri-to-buffer": { - "version": "6.0.2", - "resolved": "https://registry.npmjs.org/data-uri-to-buffer/-/data-uri-to-buffer-6.0.2.tgz", - "integrity": "sha512-7hvf7/GW8e86rW0ptuwS3OcBGDjIi6SZva7hCyWC0yYry2cOPmLIjXAUHI6DK2HsnwJd9ifmt57i8eV2n4YNpw==", - "dev": true, - "engines": { - "node": ">= 14" - } - }, - "node_modules/debug": { - "version": "4.3.4", - "resolved": "https://registry.npmjs.org/debug/-/debug-4.3.4.tgz", - "integrity": "sha512-PRWFHuSU3eDtQJPvnNY7Jcket1j0t5OuOsFzPPzsekD52Zl8qUfFIPEiswXqIvHWGVHOgX+7G/vCNNhehwxfkQ==", - "dev": true, - "dependencies": { - "ms": "2.1.2" - }, - "engines": { - "node": ">=6.0" - }, - "peerDependenciesMeta": { - "supports-color": { - "optional": true - } - } - }, - "node_modules/degenerator": { - "version": "5.0.1", - "resolved": "https://registry.npmjs.org/degenerator/-/degenerator-5.0.1.tgz", - "integrity": "sha512-TllpMR/t0M5sqCXfj85i4XaAzxmS5tVA16dqvdkMwGmzI+dXLXnw3J+3Vdv7VKw+ThlTMboK6i9rnZ6Nntj5CQ==", - "dev": true, - "dependencies": { - "ast-types": "^0.13.4", - "escodegen": "^2.1.0", - "esprima": "^4.0.1" - }, - "engines": { - "node": ">= 14" - } - }, - "node_modules/devtools-protocol": { - "version": "0.0.1299070", - "resolved": "https://registry.npmjs.org/devtools-protocol/-/devtools-protocol-0.0.1299070.tgz", - "integrity": "sha512-+qtL3eX50qsJ7c+qVyagqi7AWMoQCBGNfoyJZMwm/NSXVqLYbuitrWEEIzxfUmTNy7//Xe8yhMmQ+elj3uAqSg==", - "dev": true - }, - "node_modules/emoji-regex": { - "version": "8.0.0", - "resolved": "https://registry.npmjs.org/emoji-regex/-/emoji-regex-8.0.0.tgz", - "integrity": "sha512-MSjYzcWNOA0ewAHpz0MxpYFvwg6yjy1NG3xteoqz644VCo/RPgnr1/GGt+ic3iJTzQ8Eu3TdM14SawnVUmGE6A==", - "dev": true - }, - "node_modules/end-of-stream": { - "version": "1.4.4", - "resolved": "https://registry.npmjs.org/end-of-stream/-/end-of-stream-1.4.4.tgz", - "integrity": "sha512-+uw1inIHVPQoaVuHzRyXd21icM+cnt4CzD5rW+NC1wjOUSTOs+Te7FOv7AhN7vS9x/oIyhLP5PR1H+phQAHu5Q==", - "dev": true, - "dependencies": { - "once": "^1.4.0" - } - }, - "node_modules/env-paths": { - "version": "2.2.1", - "resolved": "https://registry.npmjs.org/env-paths/-/env-paths-2.2.1.tgz", - "integrity": "sha512-+h1lkLKhZMTYjog1VEpJNG7NZJWcuc2DDk/qsqSTRRCOXiLjeQ1d1/udrUGhqMxUgAlwKNZ0cf2uqan5GLuS2A==", - "dev": true, - "engines": { - "node": ">=6" - } - }, - "node_modules/error-ex": { - "version": "1.3.2", - "resolved": "https://registry.npmjs.org/error-ex/-/error-ex-1.3.2.tgz", - "integrity": "sha512-7dFHNmqeFSEt2ZBsCriorKnn3Z2pj+fd9kmI6QoWw4//DL+icEBfc0U7qJCisqrTsKTjw4fNFy2pW9OqStD84g==", - "dev": true, - "dependencies": { - "is-arrayish": "^0.2.1" - } - }, - "node_modules/escalade": { - "version": "3.1.2", - "resolved": "https://registry.npmjs.org/escalade/-/escalade-3.1.2.tgz", - "integrity": "sha512-ErCHMCae19vR8vQGe50xIsVomy19rg6gFu3+r3jkEO46suLMWBksvVyoGgQV+jOfl84ZSOSlmv6Gxa89PmTGmA==", - "dev": true, - "engines": { - "node": ">=6" - } - }, - "node_modules/escape-string-regexp": { - "version": "1.0.5", - "resolved": "https://registry.npmjs.org/escape-string-regexp/-/escape-string-regexp-1.0.5.tgz", - "integrity": "sha512-vbRorB5FUQWvla16U8R/qgaFIya2qGzwDrNmCZuYKrbdSUMG6I1ZCGQRefkRVhuOkIGVne7BQ35DSfo1qvJqFg==", - "dev": true, - "engines": { - "node": ">=0.8.0" - } - }, - "node_modules/escodegen": { - "version": "2.1.0", - "resolved": "https://registry.npmjs.org/escodegen/-/escodegen-2.1.0.tgz", - "integrity": "sha512-2NlIDTwUWJN0mRPQOdtQBzbUHvdGY2P1VXSyU83Q3xKxM7WHX2Ql8dKq782Q9TgQUNOLEzEYu9bzLNj1q88I5w==", - "dev": true, - "dependencies": { - "esprima": "^4.0.1", - "estraverse": "^5.2.0", - "esutils": "^2.0.2" - }, - "bin": { - "escodegen": "bin/escodegen.js", - "esgenerate": "bin/esgenerate.js" - }, - "engines": { - "node": ">=6.0" - }, - "optionalDependencies": { - "source-map": "~0.6.1" - } - }, - "node_modules/esprima": { - "version": "4.0.1", - "resolved": "https://registry.npmjs.org/esprima/-/esprima-4.0.1.tgz", - "integrity": "sha512-eGuFFw7Upda+g4p+QHvnW0RyTX/SVeJBDM/gCtMARO0cLuT2HcEKnTPvhjV6aGeqrCB/sbNop0Kszm0jsaWU4A==", - "dev": true, - "bin": { - "esparse": "bin/esparse.js", - "esvalidate": "bin/esvalidate.js" - }, - "engines": { - "node": ">=4" - } - }, - "node_modules/estraverse": { - "version": "5.3.0", - "resolved": "https://registry.npmjs.org/estraverse/-/estraverse-5.3.0.tgz", - "integrity": "sha512-MMdARuVEQziNTeJD8DgMqmhwR11BRQ/cBP+pLtYdSTnf3MIO8fFeiINEbX36ZdNlfU/7A9f3gUw49B3oQsvwBA==", - "dev": true, - "engines": { - "node": ">=4.0" - } - }, - "node_modules/esutils": { - "version": "2.0.3", - "resolved": "https://registry.npmjs.org/esutils/-/esutils-2.0.3.tgz", - "integrity": "sha512-kVscqXk4OCp68SZ0dkgEKVi6/8ij300KBWTJq32P/dYeWTSwK41WyTxalN1eRmA5Z9UU/LX9D7FWSmV9SAYx6g==", - "dev": true, - "engines": { - "node": ">=0.10.0" - } - }, - "node_modules/extract-zip": { - "version": "2.0.1", - "resolved": "https://registry.npmjs.org/extract-zip/-/extract-zip-2.0.1.tgz", - "integrity": "sha512-GDhU9ntwuKyGXdZBUgTIe+vXnWj0fppUEtMDL0+idd5Sta8TGpHssn/eusA9mrPr9qNDym6SxAYZjNvCn/9RBg==", - "dev": true, - "dependencies": { - "debug": "^4.1.1", - "get-stream": "^5.1.0", - "yauzl": "^2.10.0" - }, - "bin": { - "extract-zip": "cli.js" - }, - "engines": { - "node": ">= 10.17.0" - }, - "optionalDependencies": { - "@types/yauzl": "^2.9.1" - } - }, - "node_modules/fast-fifo": { - "version": "1.3.2", - "resolved": "https://registry.npmjs.org/fast-fifo/-/fast-fifo-1.3.2.tgz", - "integrity": "sha512-/d9sfos4yxzpwkDkuN7k2SqFKtYNmCTzgfEpz82x34IM9/zc8KGxQoXg1liNC/izpRM/MBdt44Nmx41ZWqk+FQ==", - "dev": true - }, - "node_modules/fd-slicer": { - "version": "1.1.0", - "resolved": "https://registry.npmjs.org/fd-slicer/-/fd-slicer-1.1.0.tgz", - "integrity": "sha512-cE1qsB/VwyQozZ+q1dGxR8LBYNZeofhEdUNGSMbQD3Gw2lAzX9Zb3uIU6Ebc/Fmyjo9AWWfnn0AUCHqtevs/8g==", - "dev": true, - "dependencies": { - "pend": "~1.2.0" - } - }, - "node_modules/fs-extra": { - "version": "11.2.0", - "resolved": "https://registry.npmjs.org/fs-extra/-/fs-extra-11.2.0.tgz", - "integrity": "sha512-PmDi3uwK5nFuXh7XDTlVnS17xJS7vW36is2+w3xcv8SVxiB4NyATf4ctkVY5bkSjX0Y4nbvZCq1/EjtEyr9ktw==", - "dev": true, - "dependencies": { - "graceful-fs": "^4.2.0", - "jsonfile": "^6.0.1", - "universalify": "^2.0.0" - }, - "engines": { - "node": ">=14.14" - } - }, - "node_modules/get-caller-file": { - "version": "2.0.5", - "resolved": "https://registry.npmjs.org/get-caller-file/-/get-caller-file-2.0.5.tgz", - "integrity": "sha512-DyFP3BM/3YHTQOCUL/w0OZHR0lpKeGrxotcHWcqNEdnltqFwXVfhEBQ94eIo34AfQpo0rGki4cyIiftY06h2Fg==", - "dev": true, - "engines": { - "node": "6.* || 8.* || >= 10.*" - } - }, - "node_modules/get-stream": { - "version": "5.2.0", - "resolved": "https://registry.npmjs.org/get-stream/-/get-stream-5.2.0.tgz", - "integrity": "sha512-nBF+F1rAZVCu/p7rjzgA+Yb4lfYXrpl7a6VmJrU8wF9I1CKvP/QwPNZHnOlwbTkY6dvtFIzFMSyQXbLoTQPRpA==", - "dev": true, - "dependencies": { - "pump": "^3.0.0" - }, - "engines": { - "node": ">=8" - }, - "funding": { - "url": "https://github.com/sponsors/sindresorhus" - } - }, - "node_modules/get-uri": { - "version": "6.0.3", - "resolved": "https://registry.npmjs.org/get-uri/-/get-uri-6.0.3.tgz", - "integrity": "sha512-BzUrJBS9EcUb4cFol8r4W3v1cPsSyajLSthNkz5BxbpDcHN5tIrM10E2eNvfnvBn3DaT3DUgx0OpsBKkaOpanw==", - "dev": true, - "dependencies": { - "basic-ftp": "^5.0.2", - "data-uri-to-buffer": "^6.0.2", - "debug": "^4.3.4", - "fs-extra": "^11.2.0" - }, - "engines": { - "node": ">= 14" - } - }, - "node_modules/graceful-fs": { - "version": "4.2.11", - "resolved": "https://registry.npmjs.org/graceful-fs/-/graceful-fs-4.2.11.tgz", - "integrity": "sha512-RbJ5/jmFcNNCcDV5o9eTnBLJ/HszWV0P73bc+Ff4nS/rJj+YaS6IGyiOL0VoBYX+l1Wrl3k63h/KrH+nhJ0XvQ==", - "dev": true - }, - "node_modules/has-flag": { - "version": "3.0.0", - "resolved": "https://registry.npmjs.org/has-flag/-/has-flag-3.0.0.tgz", - "integrity": "sha512-sKJf1+ceQBr4SMkvQnBDNDtf4TXpVhVGateu0t918bl30FnbE2m4vNLX+VWe/dpjlb+HugGYzW7uQXH98HPEYw==", - "dev": true, - "engines": { - "node": ">=4" - } - }, - "node_modules/http-proxy-agent": { - "version": "7.0.2", - "resolved": "https://registry.npmjs.org/http-proxy-agent/-/http-proxy-agent-7.0.2.tgz", - "integrity": "sha512-T1gkAiYYDWYx3V5Bmyu7HcfcvL7mUrTWiM6yOfa3PIphViJ/gFPbvidQ+veqSOHci/PxBcDabeUNCzpOODJZig==", - "dev": true, - "dependencies": { - "agent-base": "^7.1.0", - "debug": "^4.3.4" - }, - "engines": { - "node": ">= 14" - } - }, - "node_modules/https-proxy-agent": { - "version": "7.0.4", - "resolved": "https://registry.npmjs.org/https-proxy-agent/-/https-proxy-agent-7.0.4.tgz", - "integrity": "sha512-wlwpilI7YdjSkWaQ/7omYBMTliDcmCN8OLihO6I9B86g06lMyAoqgoDpV0XqoaPOKj+0DIdAvnsWfyAAhmimcg==", - "dev": true, - "dependencies": { - "agent-base": "^7.0.2", - "debug": "4" - }, - "engines": { - "node": ">= 14" - } - }, - "node_modules/ieee754": { - "version": "1.2.1", - "resolved": "https://registry.npmjs.org/ieee754/-/ieee754-1.2.1.tgz", - "integrity": "sha512-dcyqhDvX1C46lXZcVqCpK+FtMRQVdIMN6/Df5js2zouUsqG7I6sFxitIC+7KYK29KdXOLHdu9zL4sFnoVQnqaA==", - "dev": true, - "funding": [ - { - "type": "github", - "url": "https://github.com/sponsors/feross" - }, - { - "type": "patreon", - "url": "https://www.patreon.com/feross" - }, - { - "type": "consulting", - "url": "https://feross.org/support" - } - ] - }, - "node_modules/import-fresh": { - "version": "3.3.0", - "resolved": "https://registry.npmjs.org/import-fresh/-/import-fresh-3.3.0.tgz", - "integrity": "sha512-veYYhQa+D1QBKznvhUHxb8faxlrwUnxseDAbAp457E0wLNio2bOSKnjYDhMj+YiAq61xrMGhQk9iXVk5FzgQMw==", - "dev": true, - "dependencies": { - "parent-module": "^1.0.0", - "resolve-from": "^4.0.0" - }, - "engines": { - "node": ">=6" - }, - "funding": { - "url": "https://github.com/sponsors/sindresorhus" - } - }, - "node_modules/ip-address": { - "version": "9.0.5", - "resolved": "https://registry.npmjs.org/ip-address/-/ip-address-9.0.5.tgz", - "integrity": "sha512-zHtQzGojZXTwZTHQqra+ETKd4Sn3vgi7uBmlPoXVWZqYvuKmtI0l/VZTjqGmJY9x88GGOaZ9+G9ES8hC4T4X8g==", - "dev": true, - "dependencies": { - "jsbn": "1.1.0", - "sprintf-js": "^1.1.3" - }, - "engines": { - "node": ">= 12" - } - }, - "node_modules/is-arrayish": { - "version": "0.2.1", - "resolved": "https://registry.npmjs.org/is-arrayish/-/is-arrayish-0.2.1.tgz", - "integrity": "sha512-zz06S8t0ozoDXMG+ube26zeCTNXcKIPJZJi8hBrF4idCLms4CG9QtK7qBl1boi5ODzFpjswb5JPmHCbMpjaYzg==", - "dev": true - }, - "node_modules/is-fullwidth-code-point": { - "version": "3.0.0", - "resolved": "https://registry.npmjs.org/is-fullwidth-code-point/-/is-fullwidth-code-point-3.0.0.tgz", - "integrity": "sha512-zymm5+u+sCsSWyD9qNaejV3DFvhCKclKdizYaJUuHA83RLjb7nSuGnddCHGv0hk+KY7BMAlsWeK4Ueg6EV6XQg==", - "dev": true, - "engines": { - "node": ">=8" - } - }, - "node_modules/js-tokens": { - "version": "4.0.0", - "resolved": "https://registry.npmjs.org/js-tokens/-/js-tokens-4.0.0.tgz", - "integrity": "sha512-RdJUflcE3cUzKiMqQgsCu06FPu9UdIJO0beYbPhHN4k6apgJtifcoCtT9bcxOpYBtpD2kCM6Sbzg4CausW/PKQ==", - "dev": true - }, - "node_modules/js-yaml": { - "version": "4.1.0", - "resolved": "https://registry.npmjs.org/js-yaml/-/js-yaml-4.1.0.tgz", - "integrity": "sha512-wpxZs9NoxZaJESJGIZTyDEaYpl0FKSA+FB9aJiyemKhMwkxQg63h4T1KJgUGHpTqPDNRcmmYLugrRjJlBtWvRA==", - "dev": true, - "dependencies": { - "argparse": "^2.0.1" - }, - "bin": { - "js-yaml": "bin/js-yaml.js" - } - }, - "node_modules/jsbn": { - "version": "1.1.0", - "resolved": "https://registry.npmjs.org/jsbn/-/jsbn-1.1.0.tgz", - "integrity": "sha512-4bYVV3aAMtDTTu4+xsDYa6sy9GyJ69/amsu9sYF2zqjiEoZA5xJi3BrfX3uY+/IekIu7MwdObdbDWpoZdBv3/A==", - "dev": true - }, - "node_modules/json-parse-even-better-errors": { - "version": "2.3.1", - "resolved": "https://registry.npmjs.org/json-parse-even-better-errors/-/json-parse-even-better-errors-2.3.1.tgz", - "integrity": "sha512-xyFwyhro/JEof6Ghe2iz2NcXoj2sloNsWr/XsERDK/oiPCfaNhl5ONfp+jQdAZRQQ0IJWNzH9zIZF7li91kh2w==", - "dev": true - }, - "node_modules/jsonfile": { - "version": "6.1.0", - "resolved": "https://registry.npmjs.org/jsonfile/-/jsonfile-6.1.0.tgz", - "integrity": "sha512-5dgndWOriYSm5cnYaJNhalLNDKOqFwyDB/rr1E9ZsGciGvKPs8R2xYGCacuf3z6K1YKDz182fd+fY3cn3pMqXQ==", - "dev": true, - "dependencies": { - "universalify": "^2.0.0" - }, - "optionalDependencies": { - "graceful-fs": "^4.1.6" - } - }, - "node_modules/lines-and-columns": { - "version": "1.2.4", - "resolved": "https://registry.npmjs.org/lines-and-columns/-/lines-and-columns-1.2.4.tgz", - "integrity": "sha512-7ylylesZQ/PV29jhEDl3Ufjo6ZX7gCqJr5F7PKrqc93v7fzSymt1BpwEU8nAUXs8qzzvqhbjhK5QZg6Mt/HkBg==", - "dev": true - }, - "node_modules/lru-cache": { - "version": "7.18.3", - "resolved": "https://registry.npmjs.org/lru-cache/-/lru-cache-7.18.3.tgz", - "integrity": "sha512-jumlc0BIUrS3qJGgIkWZsyfAM7NCWiBcCDhnd+3NNM5KbBmLTgHVfWBcg6W+rLUsIpzpERPsvwUP7CckAQSOoA==", - "dev": true, - "engines": { - "node": ">=12" - } - }, - "node_modules/mitt": { - "version": "3.0.1", - "resolved": "https://registry.npmjs.org/mitt/-/mitt-3.0.1.tgz", - "integrity": "sha512-vKivATfr97l2/QBCYAkXYDbrIWPM2IIKEl7YPhjCvKlG3kE2gm+uBo6nEXK3M5/Ffh/FLpKExzOQ3JJoJGFKBw==", - "dev": true - }, - "node_modules/ms": { - "version": "2.1.2", - "resolved": "https://registry.npmjs.org/ms/-/ms-2.1.2.tgz", - "integrity": "sha512-sGkPx+VjMtmA6MX27oA4FBFELFCZZ4S4XqeGOXCv68tT+jb3vk/RyaKWP0PTKyWtmLSM0b+adUTEvbs1PEaH2w==", - "dev": true - }, - "node_modules/netmask": { - "version": "2.0.2", - "resolved": "https://registry.npmjs.org/netmask/-/netmask-2.0.2.tgz", - "integrity": "sha512-dBpDMdxv9Irdq66304OLfEmQ9tbNRFnFTuZiLo+bD+r332bBmMJ8GBLXklIXXgxd3+v9+KUnZaUR5PJMa75Gsg==", - "dev": true, - "engines": { - "node": ">= 0.4.0" - } - }, - "node_modules/once": { - "version": "1.4.0", - "resolved": "https://registry.npmjs.org/once/-/once-1.4.0.tgz", - "integrity": "sha512-lNaJgI+2Q5URQBkccEKHTQOPaXdUxnZZElQTZY0MFUAuaEqe1E+Nyvgdz/aIyNi6Z9MzO5dv1H8n58/GELp3+w==", - "dev": true, - "dependencies": { - "wrappy": "1" - } - }, - "node_modules/pac-proxy-agent": { - "version": "7.0.1", - "resolved": "https://registry.npmjs.org/pac-proxy-agent/-/pac-proxy-agent-7.0.1.tgz", - "integrity": "sha512-ASV8yU4LLKBAjqIPMbrgtaKIvxQri/yh2OpI+S6hVa9JRkUI3Y3NPFbfngDtY7oFtSMD3w31Xns89mDa3Feo5A==", - "dev": true, - "dependencies": { - "@tootallnate/quickjs-emscripten": "^0.23.0", - "agent-base": "^7.0.2", - "debug": "^4.3.4", - "get-uri": "^6.0.1", - "http-proxy-agent": "^7.0.0", - "https-proxy-agent": "^7.0.2", - "pac-resolver": "^7.0.0", - "socks-proxy-agent": "^8.0.2" - }, - "engines": { - "node": ">= 14" - } - }, - "node_modules/pac-resolver": { - "version": "7.0.1", - "resolved": "https://registry.npmjs.org/pac-resolver/-/pac-resolver-7.0.1.tgz", - "integrity": "sha512-5NPgf87AT2STgwa2ntRMr45jTKrYBGkVU36yT0ig/n/GMAa3oPqhZfIQ2kMEimReg0+t9kZViDVZ83qfVUlckg==", - "dev": true, - "dependencies": { - "degenerator": "^5.0.0", - "netmask": "^2.0.2" - }, - "engines": { - "node": ">= 14" - } - }, - "node_modules/parent-module": { - "version": "1.0.1", - "resolved": "https://registry.npmjs.org/parent-module/-/parent-module-1.0.1.tgz", - "integrity": "sha512-GQ2EWRpQV8/o+Aw8YqtfZZPfNRWZYkbidE9k5rpl/hC3vtHHBfGm2Ifi6qWV+coDGkrUKZAxE3Lot5kcsRlh+g==", - "dev": true, - "dependencies": { - "callsites": "^3.0.0" - }, - "engines": { - "node": ">=6" - } - }, - "node_modules/parse-json": { - "version": "5.2.0", - "resolved": "https://registry.npmjs.org/parse-json/-/parse-json-5.2.0.tgz", - "integrity": "sha512-ayCKvm/phCGxOkYRSCM82iDwct8/EonSEgCSxWxD7ve6jHggsFl4fZVQBPRNgQoKiuV/odhFrGzQXZwbifC8Rg==", - "dev": true, - "dependencies": { - "@babel/code-frame": "^7.0.0", - "error-ex": "^1.3.1", - "json-parse-even-better-errors": "^2.3.0", - "lines-and-columns": "^1.1.6" - }, - "engines": { - "node": ">=8" - }, - "funding": { - "url": "https://github.com/sponsors/sindresorhus" - } - }, - "node_modules/pend": { - "version": "1.2.0", - "resolved": "https://registry.npmjs.org/pend/-/pend-1.2.0.tgz", - "integrity": "sha512-F3asv42UuXchdzt+xXqfW1OGlVBe+mxa2mqI0pg5yAHZPvFmY3Y6drSf/GQ1A86WgWEN9Kzh/WrgKa6iGcHXLg==", - "dev": true - }, - "node_modules/picocolors": { - "version": "1.0.0", - "resolved": "https://registry.npmjs.org/picocolors/-/picocolors-1.0.0.tgz", - "integrity": "sha512-1fygroTLlHu66zi26VoTDv8yRgm0Fccecssto+MhsZ0D/DGW2sm8E8AjW7NU5VVTRt5GxbeZ5qBuJr+HyLYkjQ==", - "dev": true - }, - "node_modules/progress": { - "version": "2.0.3", - "resolved": "https://registry.npmjs.org/progress/-/progress-2.0.3.tgz", - "integrity": "sha512-7PiHtLll5LdnKIMw100I+8xJXR5gW2QwWYkT6iJva0bXitZKa/XMrSbdmg3r2Xnaidz9Qumd0VPaMrZlF9V9sA==", - "dev": true, - "engines": { - "node": ">=0.4.0" - } - }, - "node_modules/proxy-agent": { - "version": "6.4.0", - "resolved": "https://registry.npmjs.org/proxy-agent/-/proxy-agent-6.4.0.tgz", - "integrity": "sha512-u0piLU+nCOHMgGjRbimiXmA9kM/L9EHh3zL81xCdp7m+Y2pHIsnmbdDoEDoAz5geaonNR6q6+yOPQs6n4T6sBQ==", - "dev": true, - "dependencies": { - "agent-base": "^7.0.2", - "debug": "^4.3.4", - "http-proxy-agent": "^7.0.1", - "https-proxy-agent": "^7.0.3", - "lru-cache": "^7.14.1", - "pac-proxy-agent": "^7.0.1", - "proxy-from-env": "^1.1.0", - "socks-proxy-agent": "^8.0.2" - }, - "engines": { - "node": ">= 14" - } - }, - "node_modules/proxy-from-env": { - "version": "1.1.0", - "resolved": "https://registry.npmjs.org/proxy-from-env/-/proxy-from-env-1.1.0.tgz", - "integrity": "sha512-D+zkORCbA9f1tdWRK0RaCR3GPv50cMxcrz4X8k5LTSUD1Dkw47mKJEZQNunItRTkWwgtaUSo1RVFRIG9ZXiFYg==", - "dev": true - }, - "node_modules/pump": { - "version": "3.0.0", - "resolved": "https://registry.npmjs.org/pump/-/pump-3.0.0.tgz", - "integrity": "sha512-LwZy+p3SFs1Pytd/jYct4wpv49HiYCqd9Rlc5ZVdk0V+8Yzv6jR5Blk3TRmPL1ft69TxP0IMZGJ+WPFU2BFhww==", - "dev": true, - "dependencies": { - "end-of-stream": "^1.1.0", - "once": "^1.3.1" - } - }, - "node_modules/puppeteer": { - "version": "22.11.2", - "resolved": "https://registry.npmjs.org/puppeteer/-/puppeteer-22.11.2.tgz", - "integrity": "sha512-8fjdQSgW0sq7471ftca24J7sXK+jXZ7OW7Gx+NEBFNyXrcTiBfukEI46gNq6hiMhbLEDT30NeylK/1ZoPdlKSA==", - "dev": true, - "hasInstallScript": true, - "dependencies": { - "@puppeteer/browsers": "2.2.3", - "cosmiconfig": "9.0.0", - "devtools-protocol": "0.0.1299070", - "puppeteer-core": "22.11.2" - }, - "bin": { - "puppeteer": "lib/esm/puppeteer/node/cli.js" - }, - "engines": { - "node": ">=18" - } - }, - "node_modules/puppeteer-core": { - "version": "22.11.2", - "resolved": "https://registry.npmjs.org/puppeteer-core/-/puppeteer-core-22.11.2.tgz", - "integrity": "sha512-vQo+YDuePyvj+92Z9cdtxi/HalKf+k/R4tE80nGtQqJRNqU81eHaHkbVfnLszdaLlvwFF5tipnnSCzqWlEddtw==", - "dev": true, - "dependencies": { - "@puppeteer/browsers": "2.2.3", - "chromium-bidi": "0.5.23", - "debug": "4.3.5", - "devtools-protocol": "0.0.1299070", - "ws": "8.17.1" - }, - "engines": { - "node": ">=18" - } - }, - "node_modules/puppeteer-core/node_modules/debug": { - "version": "4.3.5", - "resolved": "https://registry.npmjs.org/debug/-/debug-4.3.5.tgz", - "integrity": "sha512-pt0bNEmneDIvdL1Xsd9oDQ/wrQRkXDT4AUWlNZNPKvW5x/jyO9VFXkJUP07vQ2upmw5PlaITaPKc31jK13V+jg==", - "dev": true, - "dependencies": { - "ms": "2.1.2" - }, - "engines": { - "node": ">=6.0" - }, - "peerDependenciesMeta": { - "supports-color": { - "optional": true - } - } - }, - "node_modules/queue-tick": { - "version": "1.0.1", - "resolved": "https://registry.npmjs.org/queue-tick/-/queue-tick-1.0.1.tgz", - "integrity": "sha512-kJt5qhMxoszgU/62PLP1CJytzd2NKetjSRnyuj31fDd3Rlcz3fzlFdFLD1SItunPwyqEOkca6GbV612BWfaBag==", - "dev": true - }, - "node_modules/require-directory": { - "version": "2.1.1", - "resolved": "https://registry.npmjs.org/require-directory/-/require-directory-2.1.1.tgz", - "integrity": "sha512-fGxEI7+wsG9xrvdjsrlmL22OMTTiHRwAMroiEeMgq8gzoLC/PQr7RsRDSTLUg/bZAZtF+TVIkHc6/4RIKrui+Q==", - "dev": true, - "engines": { - "node": ">=0.10.0" - } - }, - "node_modules/resolve-from": { - "version": "4.0.0", - "resolved": "https://registry.npmjs.org/resolve-from/-/resolve-from-4.0.0.tgz", - "integrity": "sha512-pb/MYmXstAkysRFx8piNI1tGFNQIFA3vkE3Gq4EuA1dF6gHp/+vgZqsCGJapvy8N3Q+4o7FwvquPJcnZ7RYy4g==", - "dev": true, - "engines": { - "node": ">=4" - } - }, - "node_modules/semver": { - "version": "7.6.0", - "resolved": "https://registry.npmjs.org/semver/-/semver-7.6.0.tgz", - "integrity": "sha512-EnwXhrlwXMk9gKu5/flx5sv/an57AkRplG3hTK68W7FRDN+k+OWBj65M7719OkA82XLBxrcX0KSHj+X5COhOVg==", - "dev": true, - "dependencies": { - "lru-cache": "^6.0.0" - }, - "bin": { - "semver": "bin/semver.js" - }, - "engines": { - "node": ">=10" - } - }, - "node_modules/semver/node_modules/lru-cache": { - "version": "6.0.0", - "resolved": "https://registry.npmjs.org/lru-cache/-/lru-cache-6.0.0.tgz", - "integrity": "sha512-Jo6dJ04CmSjuznwJSS3pUeWmd/H0ffTlkXXgwZi+eq1UCmqQwCh+eLsYOYCwY991i2Fah4h1BEMCx4qThGbsiA==", - "dev": true, - "dependencies": { - "yallist": "^4.0.0" - }, - "engines": { - "node": ">=10" - } - }, - "node_modules/smart-buffer": { - "version": "4.2.0", - "resolved": "https://registry.npmjs.org/smart-buffer/-/smart-buffer-4.2.0.tgz", - "integrity": "sha512-94hK0Hh8rPqQl2xXc3HsaBoOXKV20MToPkcXvwbISWLEs+64sBq5kFgn2kJDHb1Pry9yrP0dxrCI9RRci7RXKg==", - "dev": true, - "engines": { - "node": ">= 6.0.0", - "npm": ">= 3.0.0" - } - }, - "node_modules/socks": { - "version": "2.8.3", - "resolved": "https://registry.npmjs.org/socks/-/socks-2.8.3.tgz", - "integrity": "sha512-l5x7VUUWbjVFbafGLxPWkYsHIhEvmF85tbIeFZWc8ZPtoMyybuEhL7Jye/ooC4/d48FgOjSJXgsF/AJPYCW8Zw==", - "dev": true, - "dependencies": { - "ip-address": "^9.0.5", - "smart-buffer": "^4.2.0" - }, - "engines": { - "node": ">= 10.0.0", - "npm": ">= 3.0.0" - } - }, - "node_modules/socks-proxy-agent": { - "version": "8.0.3", - "resolved": "https://registry.npmjs.org/socks-proxy-agent/-/socks-proxy-agent-8.0.3.tgz", - "integrity": "sha512-VNegTZKhuGq5vSD6XNKlbqWhyt/40CgoEw8XxD6dhnm8Jq9IEa3nIa4HwnM8XOqU0CdB0BwWVXusqiFXfHB3+A==", - "dev": true, - "dependencies": { - "agent-base": "^7.1.1", - "debug": "^4.3.4", - "socks": "^2.7.1" - }, - "engines": { - "node": ">= 14" - } - }, - "node_modules/source-map": { - "version": "0.6.1", - "resolved": "https://registry.npmjs.org/source-map/-/source-map-0.6.1.tgz", - "integrity": "sha512-UjgapumWlbMhkBgzT7Ykc5YXUT46F0iKu8SGXq0bcwP5dz/h0Plj6enJqjz1Zbq2l5WaqYnrVbwWOWMyF3F47g==", - "dev": true, - "optional": true, - "engines": { - "node": ">=0.10.0" - } - }, - "node_modules/sprintf-js": { - "version": "1.1.3", - "resolved": "https://registry.npmjs.org/sprintf-js/-/sprintf-js-1.1.3.tgz", - "integrity": "sha512-Oo+0REFV59/rz3gfJNKQiBlwfHaSESl1pcGyABQsnnIfWOFt6JNj5gCog2U6MLZ//IGYD+nA8nI+mTShREReaA==", - "dev": true - }, - "node_modules/streamx": { - "version": "2.18.0", - "resolved": "https://registry.npmjs.org/streamx/-/streamx-2.18.0.tgz", - "integrity": "sha512-LLUC1TWdjVdn1weXGcSxyTR3T4+acB6tVGXT95y0nGbca4t4o/ng1wKAGTljm9VicuCVLvRlqFYXYy5GwgM7sQ==", - "dev": true, - "dependencies": { - "fast-fifo": "^1.3.2", - "queue-tick": "^1.0.1", - "text-decoder": "^1.1.0" - }, - "optionalDependencies": { - "bare-events": "^2.2.0" - } - }, - "node_modules/string-width": { - "version": "4.2.3", - "resolved": "https://registry.npmjs.org/string-width/-/string-width-4.2.3.tgz", - "integrity": "sha512-wKyQRQpjJ0sIp62ErSZdGsjMJWsap5oRNihHhu6G7JVO/9jIB6UyevL+tXuOqrng8j/cxKTWyWUwvSTriiZz/g==", - "dev": true, - "dependencies": { - "emoji-regex": "^8.0.0", - "is-fullwidth-code-point": "^3.0.0", - "strip-ansi": "^6.0.1" - }, - "engines": { - "node": ">=8" - } - }, - "node_modules/strip-ansi": { - "version": "6.0.1", - "resolved": "https://registry.npmjs.org/strip-ansi/-/strip-ansi-6.0.1.tgz", - "integrity": "sha512-Y38VPSHcqkFrCpFnQ9vuSXmquuv5oXOKpGeT6aGrr3o3Gc9AlVa6JBfUSOCnbxGGZF+/0ooI7KrPuUSztUdU5A==", - "dev": true, - "dependencies": { - "ansi-regex": "^5.0.1" - }, - "engines": { - "node": ">=8" - } - }, - "node_modules/supports-color": { - "version": "5.5.0", - "resolved": "https://registry.npmjs.org/supports-color/-/supports-color-5.5.0.tgz", - "integrity": "sha512-QjVjwdXIt408MIiAqCX4oUKsgU2EqAGzs2Ppkm4aQYbjm+ZEWEcW4SfFNTr4uMNZma0ey4f5lgLrkB0aX0QMow==", - "dev": true, - "dependencies": { - "has-flag": "^3.0.0" - }, - "engines": { - "node": ">=4" - } - }, - "node_modules/tar-fs": { - "version": "3.0.5", - "resolved": "https://registry.npmjs.org/tar-fs/-/tar-fs-3.0.5.tgz", - "integrity": "sha512-JOgGAmZyMgbqpLwct7ZV8VzkEB6pxXFBVErLtb+XCOqzc6w1xiWKI9GVd6bwk68EX7eJ4DWmfXVmq8K2ziZTGg==", - "dev": true, - "dependencies": { - "pump": "^3.0.0", - "tar-stream": "^3.1.5" - }, - "optionalDependencies": { - "bare-fs": "^2.1.1", - "bare-path": "^2.1.0" - } - }, - "node_modules/tar-stream": { - "version": "3.1.7", - "resolved": "https://registry.npmjs.org/tar-stream/-/tar-stream-3.1.7.tgz", - "integrity": "sha512-qJj60CXt7IU1Ffyc3NJMjh6EkuCFej46zUqJ4J7pqYlThyd9bO0XBTmcOIhSzZJVWfsLks0+nle/j538YAW9RQ==", - "dev": true, - "dependencies": { - "b4a": "^1.6.4", - "fast-fifo": "^1.2.0", - "streamx": "^2.15.0" - } - }, - "node_modules/text-decoder": { - "version": "1.1.0", - "resolved": "https://registry.npmjs.org/text-decoder/-/text-decoder-1.1.0.tgz", - "integrity": "sha512-TmLJNj6UgX8xcUZo4UDStGQtDiTzF7BzWlzn9g7UWrjkpHr5uJTK1ld16wZ3LXb2vb6jH8qU89dW5whuMdXYdw==", - "dev": true, - "dependencies": { - "b4a": "^1.6.4" - } - }, - "node_modules/through": { - "version": "2.3.8", - "resolved": "https://registry.npmjs.org/through/-/through-2.3.8.tgz", - "integrity": "sha512-w89qg7PI8wAdvX60bMDP+bFoD5Dvhm9oLheFp5O4a2QF0cSBGsBX4qZmadPMvVqlLJBBci+WqGGOAPvcDeNSVg==", - "dev": true - }, - "node_modules/tslib": { - "version": "2.6.3", - "resolved": "https://registry.npmjs.org/tslib/-/tslib-2.6.3.tgz", - "integrity": "sha512-xNvxJEOUiWPGhUuUdQgAJPKOOJfGnIyKySOc09XkKsgdUV/3E2zvwZYdejjmRgPCgcym1juLH3226yA7sEFJKQ==", - "dev": true - }, - "node_modules/unbzip2-stream": { - "version": "1.4.3", - "resolved": "https://registry.npmjs.org/unbzip2-stream/-/unbzip2-stream-1.4.3.tgz", - "integrity": "sha512-mlExGW4w71ebDJviH16lQLtZS32VKqsSfk80GCfUlwT/4/hNRFsoscrF/c++9xinkMzECL1uL9DDwXqFWkruPg==", - "dev": true, - "dependencies": { - "buffer": "^5.2.1", - "through": "^2.3.8" - } - }, - "node_modules/undici-types": { - "version": "5.26.5", - "resolved": "https://registry.npmjs.org/undici-types/-/undici-types-5.26.5.tgz", - "integrity": "sha512-JlCMO+ehdEIKqlFxk6IfVoAUVmgz7cU7zD/h9XZ0qzeosSHmUJVOzSQvvYSYWXkFXC+IfLKSIffhv0sVZup6pA==", - "dev": true, - "optional": true - }, - "node_modules/universalify": { - "version": "2.0.1", - "resolved": "https://registry.npmjs.org/universalify/-/universalify-2.0.1.tgz", - "integrity": "sha512-gptHNQghINnc/vTGIk0SOFGFNXw7JVrlRUtConJRlvaw6DuX0wO5Jeko9sWrMBhh+PsYAZ7oXAiOnf/UKogyiw==", - "dev": true, - "engines": { - "node": ">= 10.0.0" - } - }, - "node_modules/urlpattern-polyfill": { - "version": "10.0.0", - "resolved": "https://registry.npmjs.org/urlpattern-polyfill/-/urlpattern-polyfill-10.0.0.tgz", - "integrity": "sha512-H/A06tKD7sS1O1X2SshBVeA5FLycRpjqiBeqGKmBwBDBy28EnRjORxTNe269KSSr5un5qyWi1iL61wLxpd+ZOg==", - "dev": true - }, - "node_modules/wrap-ansi": { - "version": "7.0.0", - "resolved": "https://registry.npmjs.org/wrap-ansi/-/wrap-ansi-7.0.0.tgz", - "integrity": "sha512-YVGIj2kamLSTxw6NsZjoBxfSwsn0ycdesmc4p+Q21c5zPuZ1pl+NfxVdxPtdHvmNVOQ6XSYG4AUtyt/Fi7D16Q==", - "dev": true, - "dependencies": { - "ansi-styles": "^4.0.0", - "string-width": "^4.1.0", - "strip-ansi": "^6.0.0" - }, - "engines": { - "node": ">=10" - }, - "funding": { - "url": "https://github.com/chalk/wrap-ansi?sponsor=1" - } - }, - "node_modules/wrap-ansi/node_modules/ansi-styles": { - "version": "4.3.0", - "resolved": "https://registry.npmjs.org/ansi-styles/-/ansi-styles-4.3.0.tgz", - "integrity": "sha512-zbB9rCJAT1rbjiVDb2hqKFHNYLxgtk8NURxZ3IZwD3F6NtxbXZQCnnSi1Lkx+IDohdPlFp222wVALIheZJQSEg==", - "dev": true, - "dependencies": { - "color-convert": "^2.0.1" - }, - "engines": { - "node": ">=8" - }, - "funding": { - "url": "https://github.com/chalk/ansi-styles?sponsor=1" - } - }, - "node_modules/wrap-ansi/node_modules/color-convert": { - "version": "2.0.1", - "resolved": "https://registry.npmjs.org/color-convert/-/color-convert-2.0.1.tgz", - "integrity": "sha512-RRECPsj7iu/xb5oKYcsFHSppFNnsj/52OVTRKb4zP5onXwVF3zVmmToNcOfGC+CRDpfK/U584fMg38ZHCaElKQ==", - "dev": true, - "dependencies": { - "color-name": "~1.1.4" - }, - "engines": { - "node": ">=7.0.0" - } - }, - "node_modules/wrap-ansi/node_modules/color-name": { - "version": "1.1.4", - "resolved": "https://registry.npmjs.org/color-name/-/color-name-1.1.4.tgz", - "integrity": "sha512-dOy+3AuW3a2wNbZHIuMZpTcgjGuLU/uBL/ubcZF9OXbDo8ff4O8yVp5Bf0efS8uEoYo5q4Fx7dY9OgQGXgAsQA==", - "dev": true - }, - "node_modules/wrappy": { - "version": "1.0.2", - "resolved": "https://registry.npmjs.org/wrappy/-/wrappy-1.0.2.tgz", - "integrity": "sha512-l4Sp/DRseor9wL6EvV2+TuQn63dMkPjZ/sp9XkghTEbV9KlPS1xUsZ3u7/IQO4wxtcFB4bgpQPRcR3QCvezPcQ==", - "dev": true - }, - "node_modules/ws": { - "version": "8.17.1", - "resolved": "https://registry.npmjs.org/ws/-/ws-8.17.1.tgz", - "integrity": "sha512-6XQFvXTkbfUOZOKKILFG1PDK2NDQs4azKQl26T0YS5CxqWLgXajbPZ+h4gZekJyRqFU8pvnbAbbs/3TgRPy+GQ==", - "dev": true, - "engines": { - "node": ">=10.0.0" - }, - "peerDependencies": { - "bufferutil": "^4.0.1", - "utf-8-validate": ">=5.0.2" - }, - "peerDependenciesMeta": { - "bufferutil": { - "optional": true - }, - "utf-8-validate": { - "optional": true - } - } - }, - "node_modules/y18n": { - "version": "5.0.8", - "resolved": "https://registry.npmjs.org/y18n/-/y18n-5.0.8.tgz", - "integrity": "sha512-0pfFzegeDWJHJIAmTLRP2DwHjdF5s7jo9tuztdQxAhINCdvS+3nGINqPd00AphqJR/0LhANUS6/+7SCb98YOfA==", - "dev": true, - "engines": { - "node": ">=10" - } - }, - "node_modules/yallist": { - "version": "4.0.0", - "resolved": "https://registry.npmjs.org/yallist/-/yallist-4.0.0.tgz", - "integrity": "sha512-3wdGidZyq5PB084XLES5TpOSRA3wjXAlIWMhum2kRcv/41Sn2emQ0dycQW4uZXLejwKvg6EsvbdlVL+FYEct7A==", - "dev": true - }, - "node_modules/yargs": { - "version": "17.7.2", - "resolved": "https://registry.npmjs.org/yargs/-/yargs-17.7.2.tgz", - "integrity": "sha512-7dSzzRQ++CKnNI/krKnYRV7JKKPUXMEh61soaHKg9mrWEhzFWhFnxPxGl+69cD1Ou63C13NUPCnmIcrvqCuM6w==", - "dev": true, - "dependencies": { - "cliui": "^8.0.1", - "escalade": "^3.1.1", - "get-caller-file": "^2.0.5", - "require-directory": "^2.1.1", - "string-width": "^4.2.3", - "y18n": "^5.0.5", - "yargs-parser": "^21.1.1" - }, - "engines": { - "node": ">=12" - } - }, - "node_modules/yargs-parser": { - "version": "21.1.1", - "resolved": "https://registry.npmjs.org/yargs-parser/-/yargs-parser-21.1.1.tgz", - "integrity": "sha512-tVpsJW7DdjecAiFpbIB1e3qxIQsE6NoPc5/eTdrbbIC4h0LVsWhnoa3g+m2HclBIujHzsxZ4VJVA+GUuc2/LBw==", - "dev": true, - "engines": { - "node": ">=12" - } - }, - "node_modules/yauzl": { - "version": "2.10.0", - "resolved": "https://registry.npmjs.org/yauzl/-/yauzl-2.10.0.tgz", - "integrity": "sha512-p4a9I6X6nu6IhoGmBqAcbJy1mlC4j27vEPZX9F4L4/vZT3Lyq1VkFHw/V/PUcB9Buo+DG3iHkT0x3Qya58zc3g==", - "dev": true, - "dependencies": { - "buffer-crc32": "~0.2.3", - "fd-slicer": "~1.1.0" - } - }, - "node_modules/zod": { - "version": "3.23.8", - "resolved": "https://registry.npmjs.org/zod/-/zod-3.23.8.tgz", - "integrity": "sha512-XBx9AXhXktjUqnepgTiE5flcKIYWi/rme0Eaj+5Y0lftuGBq+jyRu/md4WnuxqgP1ubdpNCsYEYPxrzVHD8d6g==", - "dev": true, - "funding": { - "url": "https://github.com/sponsors/colinhacks" - } - } - } -} diff --git a/package.json b/package.json deleted file mode 100644 index 2793378f..00000000 --- a/package.json +++ /dev/null @@ -1,5 +0,0 @@ -{ - "devDependencies": { - "puppeteer": "^22.11.2" - } -} diff --git a/pom.xml b/pom.xml new file mode 100644 index 00000000..ee12b4ed --- /dev/null +++ b/pom.xml @@ -0,0 +1,62 @@ + + + 4.0.0 + jar + com.github.k13labs + clara-rules + clara-rules + 1.4.0 + + 1.4.0 + https://github.com/k13labs/clara-rules + scm:git:git://github.com/k13labs/clara-rules.git + scm:git:ssh://git@github.com/k13labs/clara-rules.git + + + + Apache-2.0 + https://www.apache.org/licenses/LICENSE-2.0.txt + + + + + org.clojure + clojure + 1.11.4 + + + com.cnuernber + ham-fisted + 2.017 + + + org.clojure + data.fressian + 1.1.0 + + + prismatic + schema + 1.4.1 + + + com.github.k13labs + futurama + 1.0.3 + + + org.clojure + core.cache + 1.1.234 + + + + src/main/clojure + + + + clojars + https://repo.clojars.org/ + + + diff --git a/project.clj b/project.clj deleted file mode 100644 index 7612d12e..00000000 --- a/project.clj +++ /dev/null @@ -1,100 +0,0 @@ -(defproject com.cerner/clara-rules "0.24.1-SNAPSHOT" - :description "Clara Rules Engine" - :url "https://github.com/cerner/clara-rules" - :license {:name "Apache License Version 2.0" - :url "https://www.apache.org/licenses/LICENSE-2.0"} - :dependencies [[org.clojure/clojure "1.11.2"] - [prismatic/schema "1.1.6"]] - :profiles {:dev {:dependencies [[org.clojure/math.combinatorics "0.1.3"] - [org.clojure/data.fressian "0.2.1"] - [clj-kondo/clj-kondo "2023.04.14"]] - :java-source-paths ["src/test/java"] - :global-vars {*warn-on-reflection* true}} - :provided {:dependencies [[org.clojure/clojurescript "1.11.132"]]} - :recent-clj {:dependencies [^:replace [org.clojure/clojure "1.11.2"] - ^:replace [org.clojure/clojurescript "1.11.132"]]} - :java9 {:jvm-opts ["--add-modules=java.xml.bind"]}} - :plugins [[lein-codox "0.10.3" :exclusions [org.clojure/clojure - org.clojure/clojurescript]] - [lein-javadoc "0.3.0" :exclusions [org.clojure/clojure - org.clojure/clojurescript]] - [lein-cljsbuild "1.1.8" :exclusions [org.clojure/clojure - org.clojure/clojurescript]] - [lein-figwheel "0.5.14" :exclusions [org.clojure/clojure - org.clojure/clojurescript]] - [com.github.clj-kondo/lein-clj-kondo "0.2.4" :exclusions [org.clojure/clojure - org.clojure/clojurescript]]] - :aliases {"clj-kondo-deps" ["clj-kondo" "--copy-configs" "--dependencies" "--parallel" "--lint" "$classpath"] - "clj-kondo-lint" ["do" ["clj-kondo-deps"] ["clj-kondo" "--lint" "src/main:src/test" "--fail-level" "error"]]} - :codox {:namespaces [clara.rules clara.rules.dsl clara.rules.accumulators - clara.rules.listener clara.rules.durability - clara.tools.inspect clara.tools.tracing - clara.tools.fact-graph] - :metadata {:doc/format :markdown}} - :javadoc-opts {:package-names "clara.rules"} - :source-paths ["src/main/clojure"] - :resource-paths ["clj-kondo"] - :test-paths ["src/test/clojure" "src/test/common"] - :java-source-paths ["src/main/java"] - :javac-options ["-target" "1.8" "-source" "1.8"] - :clean-targets ^{:protect false} ["resources/public/js" "target"] - :hooks [leiningen.cljsbuild] - :cljsbuild {:builds [;; Simple mode compilation for tests. - {:id "figwheel" - :source-paths ["src/test/clojurescript" "src/test/common"] - :figwheel true - :compiler {:main "clara.test" - :output-to "resources/public/js/simple.js" - :output-dir "resources/public/js/out" - :asset-path "js/out" - :optimizations :none}} - - {:id "simple" - :source-paths ["src/test/clojurescript" "src/test/common"] - :compiler {:output-to "target/js/simple.js" - :optimizations :whitespace}} - - ;; Advanced mode compilation for tests. - {:id "advanced" - :source-paths ["src/test/clojurescript" "src/test/common"] - :compiler {:output-to "target/js/advanced.js" - :anon-fn-naming-policy :mapped - :optimizations :advanced}}] - - :test-commands {"puppeteer-simple" ["node" - "src/test/js/runner.js" - "src/test/html/simple.html"] - - "puppeteer-advanced" ["node" - "src/test/js/runner.js" - "src/test/html/advanced.html"]}} - - :repl-options {;; The large number of ClojureScript tests is causing long compilation times - ;; to start the REPL. - :timeout 180000} - - ;; Factoring out the duplication of this test selector function causes an error, - ;; perhaps because Leiningen is using this as uneval'ed code. - ;; For now just duplicate the line. - :test-selectors {:default (complement (fn [x] - (let [blacklisted-packages #{"generative" "performance"} - patterns (into [] - (comp - (map #(str "^clara\\." % ".*")) - (interpose "|")) - blacklisted-packages)] - (some->> x :ns ns-name str (re-matches (re-pattern (apply str patterns))))))) - :generative (fn [x] (some->> x :ns ns-name str (re-matches #"^clara\.generative.*"))) - :performance (fn [x] (some->> x :ns ns-name str (re-matches #"^clara\.performance.*")))} - - :scm {:name "git" - :url "https://github.com/cerner/clara-rules"} - :pom-addition [:developers [:developer - [:id "rbrush"] - [:name "Ryan Brush"] - [:url "http://www.clara-rules.org"]]] - :deploy-repositories [["snapshots" {:url "https://oss.sonatype.org/content/repositories/snapshots/" - :creds :gpg}] - ["releases" {:url "https://repo.clojars.org" - :creds :gpg - :sign-releases false}]]) diff --git a/resources/.gitkeep b/resources/.gitkeep new file mode 100644 index 00000000..e69de29b diff --git a/resources/public/index.html b/resources/public/index.html deleted file mode 100644 index d290bc04..00000000 --- a/resources/public/index.html +++ /dev/null @@ -1,15 +0,0 @@ - - - - - - - - -
-

Figwheel template

-

Checkout your developer console.

-
- - - diff --git a/src/main/clojure/clara/macros.clj b/src/main/clojure/clara/macros.clj deleted file mode 100644 index 2334530b..00000000 --- a/src/main/clojure/clara/macros.clj +++ /dev/null @@ -1,279 +0,0 @@ -(ns clara.macros - "Direct use of this namespace is deprecated. Users can now - simply use the defrule, defquery, and defsession macros - in the clara.rules namespace. Users can simply pull those macros - in like any other, for instance: - - (:require [clara.rules :refer [insert fire-rules query insert!] - :refer-macros [defrule defsession defquery]]) -" - (:require [clara.rules.engine :as eng] - [clara.rules.memory :as mem] - [clara.rules.compiler :as com] - [clara.rules.dsl :as dsl] - [cljs.analyzer :as ana] - [cljs.env :as env] - [schema.core :as sc] - [clara.rules.schema :as schema] - [clojure.set :as s])) - -;;; Clear productions stored in cljs.env/*compiler* for current namespace. -;;; Only exists for its side-effect, hence returns nil. -(defmacro clear-ns-productions! - [] - (swap! env/*compiler* assoc-in [::productions (com/cljs-ns)] {}) - nil) - -;; Store production in cljs.env/*compiler* under ::productions seq? -(defn- add-production [name production] - (swap! env/*compiler* assoc-in [::productions (com/cljs-ns) name] production)) - -(defn- get-productions-from-namespace - "Returns a map of names to productions in the given namespace." - [namespace] - ;; TODO: remove need for ugly eval by changing our quoting strategy. - (let [productions (get-in @env/*compiler* [::productions namespace])] - (map eval (vals productions)))) - -(defn- get-productions - "Return the productions from the source" - [source] - (cond - (symbol? source) (get-productions-from-namespace source) - (coll? source) (seq source) - :else (throw (IllegalArgumentException. "Unknown source value type passed to defsession")))) - -(defn defrule! - [name production] - (add-production name production) - `(def ~name - ~production)) - -(defmacro defrule - [name & body] - (defrule! name (dsl/build-rule name body))) - -(defn defquery! - [name query] - (add-production name query) - `(def ~name - ~query)) - -(defmacro defquery - [name & body] - (defquery! name (dsl/build-query name body))) - -(sc/defn gen-beta-network :- [sc/Any] ; Returns a sequence of compiled nodes. - "Generates the beta network from the beta tree. " - ([node-ids :- #{sc/Int} ; Nodes to compile. - {:keys [id-to-production-node id-to-condition-node id-to-new-bindings forward-edges] :as beta-graph} :- schema/BetaGraph - parent-bindings :- #{sc/Keyword}] - (vec - (for [id node-ids - :let [beta-node (or (get id-to-condition-node id) - (get id-to-production-node id)) - - {:keys [condition production query join-bindings]} beta-node - - child-ids (get forward-edges id) - - constraint-bindings (com/variables-as-keywords (:constraints condition)) - - ;; Get all bindings from the parent, condition, and returned fact. - all-bindings (cond-> (s/union parent-bindings constraint-bindings) - ;; Optional fact binding from a condition. - (:fact-binding condition) (conj (:fact-binding condition)) - ;; Optional accumulator result. - (:result-binding beta-node) (conj (:result-binding beta-node))) - - new-bindings (get id-to-new-bindings id)]] - - (case (:node-type beta-node) - - :join - (if (:join-filter-expressions beta-node) - `(eng/->ExpressionJoinNode - ~id - '~condition - ~(com/compile-join-filter id - "ExpressionJoinNode" - (:join-filter-expressions beta-node) - (:join-filter-join-bindings beta-node) - (:new-bindings beta-node) - {}) - ~(gen-beta-network child-ids beta-graph all-bindings) - ~join-bindings) - `(eng/->HashJoinNode - ~id - '~condition - ~(gen-beta-network child-ids beta-graph all-bindings) - ~join-bindings)) - - :negation - (if (:join-filter-expressions beta-node) - `(eng/->NegationWithJoinFilterNode - ~id - '~condition - ~(com/compile-join-filter id - "NegationWithJoinFilterNode" - (:join-filter-expressions beta-node) - (:join-filter-join-bindings beta-node) - (:new-bindings beta-node) - {}) - ~(gen-beta-network child-ids beta-graph all-bindings) - ~join-bindings) - `(eng/->NegationNode - ~id - '~condition - ~(gen-beta-network child-ids beta-graph all-bindings) - ~join-bindings)) - - :test - `(eng/->TestNode - ~id - ~(:env beta-node) - ~(:constraints condition) - ~(com/compile-test id (:constraints condition) (:env beta-node)) - ~(gen-beta-network child-ids beta-graph all-bindings)) - - :accumulator - (if (:join-filter-expressions beta-node) - `(eng/->AccumulateWithJoinFilterNode - ~id - {:accumulator '~(:accumulator beta-node) - :from '~condition} - ~(:accumulator beta-node) - ~(com/compile-join-filter id - "AccumulateWithJoinFilterNode" - (:join-filter-expressions beta-node) - (:join-filter-join-bindings beta-node) - (:new-bindings beta-node) - {}) - ~(:result-binding beta-node) - ~(gen-beta-network child-ids beta-graph all-bindings) - ~join-bindings - ~new-bindings) - - `(eng/->AccumulateNode - ~id - {:accumulator '~(:accumulator beta-node) - :from '~condition} - ~(:accumulator beta-node) - ~(:result-binding beta-node) - ~(gen-beta-network child-ids beta-graph all-bindings) - ~join-bindings - ~new-bindings)) - - :production - `(eng/->ProductionNode - ~id - '~production - ;; NOTE: This is a workaround around allowing the compiler to eval this - ;; form in an unknown ns. It will suffer from var shadowing problems described - ;; @ https://github.com/cerner/clara-rules/issues/178. - ;; A better solution may be to enhance dsl/resolve-vars to deal with shadowing - ;; correctly in cljs. This may be easier to do there since the compiler's - ;; analyzer may be more exposed than on the clj side. - ~(let [resolve-vars #(@#'dsl/resolve-vars (:rhs production) - ;; It is unlikely that passing the bindings matters, - ;; but all:fact-binding from the LHS conditions were - ;; made available here in the past. However, all - ;; bindings begin with "?" which typically means - ;; that a rule wouldn't, or at least shouldn't for - ;; clarity, start the names of other locals or vars - ;; with "?". - (mapv (comp symbol name) all-bindings))] - (com/compile-action id - all-bindings - ;; Using private function for now as a workaround. - (if (:ns-name production) - (if (com/compiling-cljs?) - (binding [cljs.analyzer/*cljs-ns* (:ns-name production)] - (resolve-vars)) - (binding [*ns* (the-ns (:ns-name production))] - (resolve-vars))) - (resolve-vars)) - (:env production)))) - - :query - `(eng/->QueryNode - ~id - '~query - ~(:params query)) - (throw (ex-info (str "Unknown node type " (:node-type beta-node)) {:node beta-node}))))))) - -(sc/defn ^:always-validate compile-alpha-nodes - [alpha-nodes :- [schema/AlphaNode]] - (vec - (for [{:keys [id condition beta-children env]} alpha-nodes - :let [{:keys [type constraints fact-binding args]} condition]] - - {:id id - :type (com/effective-type type) - :alpha-fn (com/compile-condition type id (first args) constraints fact-binding env) - :children (vec beta-children)}))) - -(defn productions->session-assembly-form - [productions options] - ;;; Calling com/names-unique here rather than in sources-and-options->session-assembly-form - ;;; as a ClojureScript DSL may call productions->session-assembly-form if that DSL - ;;; has its own mechanism for grouping rules which is different than the clara DSL. - (com/validate-names-unique productions) - (let [id-counter (atom 0) - create-id-fn (fn [] (swap! id-counter inc)) - - beta-graph (com/to-beta-graph productions create-id-fn) - ;; Compile the children of the logical root condition. - beta-network (gen-beta-network (get-in beta-graph [:forward-edges 0]) beta-graph #{}) - - alpha-graph (com/to-alpha-graph beta-graph create-id-fn) - alpha-nodes (compile-alpha-nodes alpha-graph)] - - `(let [beta-network# ~beta-network - alpha-nodes# ~alpha-nodes - productions# '~productions - options# ~options] - (clara.rules/assemble-session beta-network# alpha-nodes# productions# options#)))) - -(defn sources-and-options->session-assembly-form - [sources-and-options] - (let [sources (take-while #(not (keyword? %)) sources-and-options) - options (apply hash-map (drop-while #(not (keyword? %)) sources-and-options)) - ;; Eval to unquote ns symbols, and to eval exprs to look up - ;; explicit rule sources - sources (eval (vec sources)) - productions (vec (for [source sources - production (get-productions source)] - production))] - (productions->session-assembly-form productions options))) - -(defmacro defsession - "Creates a session given a list of sources and keyword-style options, which are typically ClojureScript namespaces. - - Each source is eval'ed at compile time, in Clojure (not ClojureScript.) - - If the eval result is a symbol, it is presumed to be a ClojureScript - namespace, and all rules and queries defined in that namespace will - be found and used. - - If the eval result is a collection, it is presumed to be a - collection of productions. Note that although the collection must - exist in the compiling Clojure runtime (since the eval happens at - macro-expansion time), any expressions in the rule or query - definitions will be executed in ClojureScript. - - Typical usage would be like this, with a session defined as a var: - - (defsession my-session 'example.namespace) - - That var contains an immutable session that then can be used as a starting point to create sessions with - caller-provided data. Since the session itself is immutable, it can be safely used from multiple threads - and will not be modified by callers. So a user might grab it, insert facts, and otherwise - use it as follows: - - (-> my-session - (insert (->Temperature 23)) - (fire-rules)) - " - [name & sources-and-options] - `(def ~name ~(sources-and-options->session-assembly-form sources-and-options))) diff --git a/src/main/clojure/clara/rules.clj b/src/main/clojure/clara/rules.clj new file mode 100644 index 00000000..f6d80982 --- /dev/null +++ b/src/main/clojure/clara/rules.clj @@ -0,0 +1,327 @@ +(ns clara.rules + "Forward-chaining rules for Clojure. The primary API is in this namespace." + (:require [clara.rules.engine :as eng] + [clara.rules.platform :as platform] + [clara.rules.compiler :as com] + [clara.rules.dsl :as dsl])) + +(defn insert + "Inserts one or more facts into a working session. It does not modify the given + session, but returns a new session with the facts added." + [session & facts] + (eng/insert session facts)) + +(defn insert-all + "Inserts a sequence of facts into a working session. It does not modify the given + session, but returns a new session with the facts added." + [session fact-seq] + (eng/insert session fact-seq)) + +(defn retract + "Retracts a fact from a working session. It does not modify the given session, + but returns a new session with the facts retracted." + [session & facts] + (eng/retract session facts)) + +(defn fire-rules + "Fires are rules in the given session. Once a rule is fired, it is labeled in a fired + state and will not be re-fired unless facts affecting the rule are added or retracted. + + This function does not modify the given session to mark rules as fired. Instead, it returns + a new session in which the rules are marked as fired. + + This take an additional map of options as a second argument. Current options: + + :cancelling true (EXPERIMENTAL, subject to change/removal. Not supported in ClojureScript.): + Simultaneously propagate insertions and retractions through the rules network, at every step using the insertion and retractions of equals facts to cancel each + other out and avoid operations deeper in the rules network. The behavior of unconditional insertions and RHS (right-hand side) retractions + is undefined when this option is enabled and this option should not be used when calling fire-rules can result in these operations. + Note that this is purely a performance optimization and no guarantees are made at this time on whether a given rule's RHS will be called. + When this option is used rule RHS code that is executed shouldn't do anything that impacts state other than perform logical insertions." + ([session] (eng/fire-rules session {})) + ([session opts] (eng/fire-rules session opts))) + +(defn fire-rules-async + "Fires are rules in the given session. Once a rule is fired, it is labeled in a fired + state and will not be re-fired unless facts affecting the rule are added or retracted. + + This function does not modify the given session to mark rules as fired. Instead, it returns + a new session in which the rules are marked as fired. + + This take an additional map of options as a second argument. Current options: + :parallel-batch-size (NEW, subject to change/updates in the future): + Allow the rules engine to fire rule RHS activations in batches of N (default N = 1) rules at most, allowing RHS of rules which return + async results such as Futures, CompletableFutures, Deferreds, Channels to be fired simultaneously and await the results without blocking. + + :cancelling true (EXPERIMENTAL, subject to change/removal.): + Simultaneously propagate insertions and retractions through the rules network, at every step using the insertion and retractions of equals facts to cancel each + other out and avoid operations deeper in the rules network. The behavior of unconditional insertions and RHS (right-hand side) retractions + is undefined when this option is enabled and this option should not be used when calling fire-rules can result in these operations. + Note that this is purely a performance optimization and no guarantees are made at this time on whether a given rule's RHS will be called. + When this option is used rule RHS code that is executed shouldn't do anything that impacts state other than perform logical insertions." + ([session] (eng/fire-rules-async session {})) + ([session opts] (eng/fire-rules-async session opts))) + +(defn query + "Runs the given query with the optional given parameters against the session. + The optional parameters should be in map form. For example, a query call might be: + + (query session get-by-last-name :?last-name \"Jones\") + + The query itself may be either the var created by a defquery statement, + or the actual name of the query. + " + [session query & params] + (let [params-map (->> (for [[param value] (apply hash-map params)] + [(platform/query-param param) value]) + (into {}))] + (eng/query session query params-map))) + +(defn insert! + "To be executed within a rule's right-hand side, this inserts a new fact or facts into working memory. + + Inserted facts are logical, in that if the support for the insertion is removed, the fact + will automatically be retracted. For instance, if there is a rule that inserts a \"Cold\" fact + if a \"Temperature\" fact is below a threshold, and the \"Temperature\" fact that triggered + the rule is retracted, the \"Cold\" fact the rule inserted is also retracted. This is the underlying + truth maintenance facillity. + + This truth maintenance is also transitive: if a rule depends on some criteria to fire, and a + criterion becomes invalid, it may retract facts that invalidate other rules, which in turn + retract their conclusions. This way we can ensure that information inferred by rules is always + in a consistent state." + [& facts] + (eng/insert-facts! facts false)) + +(defn insert-all! + "Behaves the same as insert!, but accepts a sequence of facts to be inserted. This can be simpler and more efficient for + rules needing to insert multiple facts. + + See the doc in insert! for details on insert behavior.." + [facts] + (eng/insert-facts! facts false)) + +(defn insert-unconditional! + "To be executed within a rule's right-hand side, this inserts a new fact or facts into working memory. + + This differs from insert! in that it is unconditional. The facts inserted will not be retracted + even if the rule activation doing the insert becomes false. Most users should prefer the simple insert! + function as described above, but this function is available for use cases that don't wish to use + Clara's truth maintenance." + [& facts] + (eng/insert-facts! facts true)) + +(defn insert-all-unconditional! + "Behaves the same as insert-unconditional!, but accepts a sequence of facts to be inserted rather than individual facts. + + See the doc in insert-unconditional! for details on uncondotional insert behavior." + [facts] + (eng/insert-facts! facts true)) + +(defn retract! + "To be executed within a rule's right-hand side, this retracts a fact or facts from the working memory. + + Retracting facts from the right-hand side has slightly different semantics than insertion. As described + in the insert! documentation, inserts are logical and will automatically be retracted if the rule + that inserted them becomes false. This retract! function does not follow the inverse; retracted items + are simply removed, and not re-added if the rule that retracted them becomes false. + + The reason for this is that retractions remove information from the knowledge base, and doing truth + maintenance over retractions would require holding onto all retracted items, which would be an issue + in some use cases. This retract! method is included to help with certain use cases, but unless you + have a specific need, it is better to simply do inserts on the rule's right-hand side, and let + Clara's underlying truth maintenance retract inserted items if their support becomes false." + [& facts] + (eng/rhs-retract-facts! facts)) + +(extend-type clojure.lang.Fn + com/IClaraSource + (load-source [afn] + [(afn)])) + +(extend-type clojure.lang.Symbol + com/IClaraSource + (load-source [sym] + ;; Find the rules and queries in the namespace, shred them, + ;; and compile them into a rule base. + (if (namespace sym) + ;; The symbol is qualified, so load rules in the qualified symbol. + (let [resolved (resolve sym)] + (when (nil? resolved) + (throw (ex-info (str "Unable to resolve clara source: " sym) {:sym sym}))) + + (cond + ;; The symbol references a rule or query, so just load it + (or (:query (meta resolved)) + (:rule (meta resolved)) + (:hierarchy (meta resolved))) + (com/load-source* @resolved) + + ;; The symbol references a sequence, so ensure we load all sources. + (sequential? @resolved) + (mapcat com/load-source* @resolved) + + :else + [])) + + ;; The symbol is not qualified, so treat it as a namespace. + (->> (ns-interns sym) + (vals) ; Get the references in the namespace. + (filter var?) + (filter (comp (some-fn :rule :query :hierarchy :hierarchy-seq :production-seq) meta)) ; Filter down to rules, queries, and seqs of both. + ;; If definitions are created dynamically (i.e. are not reflected in an actual code file) + ;; it is possible that they won't have :line metadata, so we have a default of 0. + (sort (fn [v1 v2] + (compare (or (:line (meta v1)) 0) + (or (:line (meta v2)) 0)))) + (mapcat com/load-source*))))) + +(defmacro mk-session + "Creates a new session using the given rule sources. The resulting session + is immutable, and can be used with insert, retract, fire-rules, and query functions. + + If no sources are provided, it will attempt to load rules from the caller's namespace, + which is determined by reading Clojure's *ns* var. + + This will use rules defined with defrule, queries defined with defquery, and sequences + of rule and/or query structures in vars that are annotated with the metadata ^:production-seq. + + The caller may also specify keyword-style options at the end of the parameters. Currently five + options are supported, although most users will either not need these or just the first two: + + * :fact-type-fn, which must have a value of a function used to determine the logical type of a given + fact. Defaults to Clojure's type function. + * :cache, indicating whether the session creation can be cached, effectively memoizing mk-session, + valid values are true, false, or a wrapped CacheProtocol. + * :compiler-cache, indicating wether the expression compilation can be cached, effectively memoizing eval expr, + valid values are true, false, or a wrapped CacheProtocol. + Defaults to true. Callers may wish to set this to false when needing to dynamically reload rules. + * :ancestors-fn, which returns a collection of ancestors for a given type. Defaults to Clojure's ancestors function. A + fact of a given type will match any rule that uses one of that type's ancestors. Note that if the collection is ordered + this ordering will be maintained by Clara; ordering the ancestors consistently will increase the consistency of overall performance. + * :hierarchy, can be used to get ancestors using Clojure's ancestors function. This an alternative or compliment to + providing a custom :ancestors-fn function. + * :activation-group-fn, a function applied to production structures and returns the group they should be activated with. + It defaults to checking the :salience property, or 0 if none exists. + * :activation-group-sort-fn, a comparator function used to sort the values returned by the above :activation-group-fn. + Defaults to >, so rules with a higher salience are executed first. + * :forms-per-eval - The maximum number of expressions that will be evaluated per call to eval. + Larger batch sizes should see better performance compared to smaller batch sizes. (Only applicable to Clojure) + Defaults to 5000, see clara.rules.compiler/forms-per-eval-default for more information. + * :omit-compile-ctx - When false Clara, in Clojure, retains additional information to improve error messages during + session deserialization at the cost of additional memory use. + By default this information is retained until the session is initially compiled and then will be discarded. This + information might prove useful for debugging compilation errors within the rulebase, eg. rulebase serialization + (ie. via Clara's durability support). + Defaults to true, see clara.rules.compiler/omit-compile-ctx-default for more information. + + This is not supported in ClojureScript, since it requires eval to dynamically build a session. ClojureScript + users must use pre-defined rule sessions using defsession." + [& args] + (if (and (seq args) (not (keyword? (first args)))) + `(com/mk-session ~(vec args)) ; At least one namespace given, so use it. + `(com/mk-session (concat [(ns-name *ns*)] ~(vec args))))) ; No namespace given, so use the current one. + +(defmacro defsession + "Creates a sesson given a list of sources and keyword-style options, which are typically Clojure namespaces. + + Typical usage would be like this, with a session defined as a var: + + (defsession my-session 'example.namespace) + + That var contains an immutable session that then can be used as a starting point to create sessions with + caller-provided data. Since the session itself is immutable, it can be safely used from multiple threads + and will not be modified by callers. So a user might grab it, insert facts, and otherwise + use it as follows: + + (-> my-session + (insert (->Temperature 23)) + (fire-rules))" + [name & sources-and-options] + `(def ~name (com/mk-session ~(vec sources-and-options)))) + +(defmacro defrule + "Defines a rule and stores it in the given var. For instance, a simple rule would look like this: + + (defrule hvac-approval + \"HVAC repairs need the appropriate paperwork, so insert + a validation error if approval is not present.\" + [WorkOrder (= type :hvac)] + [:not [ApprovalForm (= formname \"27B-6\")]] + => + (insert! (->ValidationError + :approval + \"HVAC repairs must include a 27B-6 form.\"))) + + See the [rule authoring documentation](http://www.clara-rules.org/docs/rules/) for details." + [rule-name & body] + (let [doc (if (string? (first body)) (first body) nil) + rule (dsl/build-rule rule-name body &env (meta &form)) ;;; Full rule LHS + RHS + rule-action (dsl/build-rule-action rule-name body &env (meta &form)) ;;; Only the RHS + rule-node (com/build-rule-node rule-action) ;;; The Node of the RHS + {:keys [bindings production]} rule-node + rule-handler (com/compile-action-handler rule-name bindings + (:rhs production) + (:env production)) + [rule-args & rule-body] (drop 2 rule-handler) + name-with-meta (vary-meta rule-name assoc :rule true :doc doc) + handler-name (symbol (name (ns-name *ns*)) (name rule-name))] ;;; The compiled RHS + `(defn ~name-with-meta + ([] + (assoc ~rule :handler '~handler-name)) + ([~@(take 1 rule-args)] + (~rule-name '?__token__ {})) + ([~@rule-args] + ~@rule-body)))) + +(defmacro defquery + "Defines a query and stores it in the given var. For instance, a simple query that accepts no + parameters would look like this: + + (defquery check-job + \"Checks the job for validation errors.\" + [] + [?issue <- ValidationError]) + + See the [query authoring documentation](http://www.clara-rules.org/docs/queries/) for details." + [name & body] + (let [doc (if (string? (first body)) (first body) nil)] + `(def ~(vary-meta name assoc :query true :doc doc) + ~(dsl/build-query name body &env (meta &form))))) + +(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\" + :order/hvac :order/service + :order/plumber :order/service + :order/cinema :order/service)" + [name & body] + (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) + (-> (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. + Rule and query definitions can be cached such that if their definitions are not explicitly overwritten with the same + name (i.e. deleted or renamed), the stale definitions can be loaded into a session using that namespace on + reload via the REPL or mechanism such as figwheel. Place (clear-ns-vars!) at the top of any namespace + defining rules/queries to ensure the cache is cleared properly." + [] + (let [clara-syms (->> (ns-interns *ns*) + (filter (comp var? second)) + (filter (comp (some-fn :rule + :query + :hierarchy + :production-seq) meta second)) ; Filter down to rules, queries, facts, and hierarchy. + (map first))] ; Take the symbols for each var + (doseq [psym clara-syms] + (ns-unmap *ns* psym)))) diff --git a/src/main/clojure/clara/rules.cljc b/src/main/clojure/clara/rules.cljc deleted file mode 100644 index ea0e404a..00000000 --- a/src/main/clojure/clara/rules.cljc +++ /dev/null @@ -1,431 +0,0 @@ -(ns clara.rules - "Forward-chaining rules for Clojure. The primary API is in this namespace." - (:require [clara.rules.engine :as eng] - [schema.core :as s] - [clara.rules.platform :as platform] - #?(:cljs [clara.rules.listener :as l]) - #?(:clj [clara.rules.compiler :as com]) - #?(:clj [clara.rules.dsl :as dsl])) - #?(:cljs (:require-macros clara.rules))) - -(defn insert - "Inserts one or more facts into a working session. It does not modify the given - session, but returns a new session with the facts added." - [session & facts] - (eng/insert session facts)) - -(defn insert-all - "Inserts a sequence of facts into a working session. It does not modify the given - session, but returns a new session with the facts added." - [session fact-seq] - (eng/insert session fact-seq)) - -(defn retract - "Retracts a fact from a working session. It does not modify the given session, - but returns a new session with the facts retracted." - [session & facts] - (eng/retract session facts)) - -(defn fire-rules - "Fires are rules in the given session. Once a rule is fired, it is labeled in a fired - state and will not be re-fired unless facts affecting the rule are added or retracted. - - This function does not modify the given session to mark rules as fired. Instead, it returns - a new session in which the rules are marked as fired. - - This take an additional map of options as a second argument. Current options: - - :cancelling true (EXPERIMENTAL, subject to change/removal. Not supported in ClojureScript.): - Simultaneously propagate insertions and retractions through the rules network, at every step using the insertion and retractions of equals facts to cancel each - other out and avoid operations deeper in the rules network. The behavior of unconditional insertions and RHS (right-hand side) retractions - is undefined when this option is enabled and this option should not be used when calling fire-rules can result in these operations. - Note that this is purely a performance optimization and no guarantees are made at this time on whether a given rule's RHS will be called. - When this option is used rule RHS code that is executed shouldn't do anything that impacts state other than perform logical insertions." - ([session] (eng/fire-rules session {})) - ([session opts] (eng/fire-rules session opts))) - -(defn query - "Runs the given query with the optional given parameters against the session. - The optional parameters should be in map form. For example, a query call might be: - - (query session get-by-last-name :?last-name \"Jones\") - - The query itself may be either the var created by a defquery statement, - or the actual name of the query. - " - [session query & params] - (let [params-map (->> (for [[param value] (apply hash-map params)] - [(platform/query-param param) value]) - (into {}))] - (eng/query session query params-map))) - -(defn insert! - "To be executed within a rule's right-hand side, this inserts a new fact or facts into working memory. - - Inserted facts are logical, in that if the support for the insertion is removed, the fact - will automatically be retracted. For instance, if there is a rule that inserts a \"Cold\" fact - if a \"Temperature\" fact is below a threshold, and the \"Temperature\" fact that triggered - the rule is retracted, the \"Cold\" fact the rule inserted is also retracted. This is the underlying - truth maintenance facillity. - - This truth maintenance is also transitive: if a rule depends on some criteria to fire, and a - criterion becomes invalid, it may retract facts that invalidate other rules, which in turn - retract their conclusions. This way we can ensure that information inferred by rules is always - in a consistent state." - [& facts] - (eng/insert-facts! facts false)) - -(defn insert-all! - "Behaves the same as insert!, but accepts a sequence of facts to be inserted. This can be simpler and more efficient for - rules needing to insert multiple facts. - - See the doc in insert! for details on insert behavior.." - [facts] - (eng/insert-facts! facts false)) - -(defn insert-unconditional! - "To be executed within a rule's right-hand side, this inserts a new fact or facts into working memory. - - This differs from insert! in that it is unconditional. The facts inserted will not be retracted - even if the rule activation doing the insert becomes false. Most users should prefer the simple insert! - function as described above, but this function is available for use cases that don't wish to use - Clara's truth maintenance." - [& facts] - (eng/insert-facts! facts true)) - -(defn insert-all-unconditional! - "Behaves the same as insert-unconditional!, but accepts a sequence of facts to be inserted rather than individual facts. - - See the doc in insert-unconditional! for details on uncondotional insert behavior." - [facts] - (eng/insert-facts! facts true)) - -(defn retract! - "To be executed within a rule's right-hand side, this retracts a fact or facts from the working memory. - - Retracting facts from the right-hand side has slightly different semantics than insertion. As described - in the insert! documentation, inserts are logical and will automatically be retracted if the rule - that inserted them becomes false. This retract! function does not follow the inverse; retracted items - are simply removed, and not re-added if the rule that retracted them becomes false. - - The reason for this is that retractions remove information from the knowledge base, and doing truth - maintenance over retractions would require holding onto all retracted items, which would be an issue - in some use cases. This retract! method is included to help with certain use cases, but unless you - have a specific need, it is better to simply do inserts on the rule's right-hand side, and let - Clara's underlying truth maintenance retract inserted items if their support becomes false." - [& facts] - (eng/rhs-retract-facts! facts)) - -(defn accumulate - "DEPRECATED. Use clara.rules.accumulators/accum instead. - - Creates a new accumulator based on the given properties: - - * An initial-value to be used with the reduced operations. - * A reduce-fn that can be used with the Clojure Reducers library to reduce items. - * An optional combine-fn that can be used with the Clojure Reducers library to combine reduced items. - * An optional retract-fn that can remove a retracted fact from a previously reduced computation - * An optional convert-return-fn that converts the reduced data into something useful to the caller. - Simply uses identity by default. - " - [& {:keys [initial-value reduce-fn combine-fn retract-fn convert-return-fn] :as args}] - (eng/map->Accumulator - (merge {;; Default conversion does nothing, so use identity. - :convert-return-fn identity} - args))) - -#?(:cljs - (defrecord Rulebase [alpha-roots beta-roots productions queries production-nodes query-nodes id-to-node])) - -#?(:cljs - (defn- create-get-alphas-fn - "Returns a function that given a sequence of facts, - returns a map associating alpha nodes with the facts they accept." - [fact-type-fn ancestors-fn merged-rules] - - ;; We preserve a map of fact types to alpha nodes for efficiency, - ;; effectively memoizing this operation. - (let [alpha-map (atom {}) - wrapped-fact-type-fn (if (= fact-type-fn type) - type - (fn [fact] - (if (isa? (type fact) :clara.rules.engine/system-type) - ;; Internal system types always use ClojureScript's type mechanism. - (type fact) - ;; All other types defer to the provided function. - (fact-type-fn fact)))) - wrapped-ancestors-fn (fn [fact-type] - (if (isa? fact-type :clara.rules.engine/system-type) - ;; Exclude system types from having ancestors for now - ;; since none of our use-cases require them. If this changes - ;; we may need to define a custom hierarchy for them. - #{} - (ancestors-fn fact-type)))] - (fn [facts] - (for [[fact-type facts] (platform/tuned-group-by wrapped-fact-type-fn facts)] - - (if-let [alpha-nodes (get @alpha-map fact-type)] - - ;; If the matching alpha nodes are cached, simply return them. - [alpha-nodes facts] - - ;; The alpha nodes weren't cached for the type, so get them now. - (let [ancestors (conj (wrapped-ancestors-fn fact-type) fact-type) - - ;; Get all alpha nodes for all ancestors. - new-nodes (distinct - (reduce - (fn [coll ancestor] - (concat - coll - (get-in merged-rules [:alpha-roots ancestor]))) - [] - ancestors))] - - (swap! alpha-map assoc fact-type new-nodes) - [new-nodes facts]))))))) - -#?(:cljs - (defn- mk-rulebase - [beta-roots alpha-fns productions] - - (let [beta-nodes (for [root beta-roots - node (tree-seq :children :children root)] - node) - - production-nodes (for [node beta-nodes - :when (= eng/ProductionNode (type node))] - node) - - query-nodes (for [node beta-nodes - :when (= eng/QueryNode (type node))] - node) - - query-map (into {} (for [query-node query-nodes - - ;; Queries can be looked up by reference or by name; - entry [[(:query query-node) query-node] - [(:name (:query query-node)) query-node]]] - entry)) - - ;; Map of node ids to beta nodes. - id-to-node (into {} (for [node beta-nodes] - [(:id node) node])) - - ;; type, alpha node tuples. - alpha-nodes (for [{:keys [id type alpha-fn children env]} alpha-fns - :let [beta-children (map id-to-node children)]] - [type (eng/->AlphaNode id env beta-children alpha-fn type)]) - - ;; Merge the alpha nodes into a multi-map - alpha-map (reduce - (fn [alpha-map [type alpha-node]] - (update-in alpha-map [type] conj alpha-node)) - {} - alpha-nodes)] - - (map->Rulebase - {:alpha-roots alpha-map - :beta-roots beta-roots - :productions (filter :rhs productions) - :queries (remove :rhs productions) - :production-nodes production-nodes - :query-nodes query-map - :id-to-node id-to-node})))) - - -#?(:cljs - (defn assemble-session - "This is used by tools to create a session; most users won't use this function." - [beta-roots alpha-fns productions options] - (let [rulebase (mk-rulebase beta-roots alpha-fns productions) - transport (eng/LocalTransport.) - - ;; The fact-type uses Clojure's type function unless overridden. - fact-type-fn (or (get options :fact-type-fn) - type) - - ;; The ancestors for a logical type uses Clojurescript's ancestors function unless overridden. - ancestors-fn (or (get options :ancestors-fn) - ancestors) - - ;; Create a function that groups a sequence of facts by the collection - ;; of alpha nodes they target. - ;; We cache an alpha-map for facts of a given type to avoid computing - ;; them for every fact entered. - get-alphas-fn (create-get-alphas-fn fact-type-fn ancestors-fn rulebase) - - activation-group-sort-fn (eng/options->activation-group-sort-fn options) - - activation-group-fn (eng/options->activation-group-fn options) - - listener (if-let [listeners (:listeners options)] - (l/delegating-listener listeners) - l/default-listener)] - - (eng/LocalSession. rulebase - (eng/local-memory rulebase transport activation-group-sort-fn activation-group-fn get-alphas-fn) - transport - listener - get-alphas-fn - [])))) - -#?(:clj - (extend-type clojure.lang.Symbol - com/IRuleSource - (load-rules [sym] - ;; Find the rules and queries in the namespace, shred them, - ;; and compile them into a rule base. - (if (namespace sym) - ;; The symbol is qualified, so load rules in the qualified symbol. - (let [resolved (resolve sym)] - (when (nil? resolved) - (throw (ex-info (str "Unable to resolve rule source: " sym) {:sym sym}))) - - (cond - ;; The symbol references a rule or query, so just return it - (or (:query (meta resolved)) - (:rule (meta resolved))) [@resolved] - - ;; The symbol refernces a sequence, so return it. - (sequential? @resolved) @resolved - - :default - (throw (ex-info (str "The source referenced by " sym " is not valid.") {:sym sym} )))) - - ;; The symbol is not qualified, so treat it as a namespace. - (->> (ns-interns sym) - (vals) ; Get the references in the namespace. - (filter var?) - (filter (comp (some-fn :rule :query :production-seq) meta)) ; Filter down to rules, queries, and seqs of both. - ;; If definitions are created dynamically (i.e. are not reflected in an actual code file) - ;; it is possible that they won't have :line metadata, so we have a default of 0. - (sort (fn [v1 v2] - (compare (or (:line (meta v1)) 0) - (or (:line (meta v2)) 0)))) - (mapcat #(if (:production-seq (meta %)) - (deref %) - [(deref %)]))))))) - -#?(:clj - (defmacro mk-session - "Creates a new session using the given rule sources. The resulting session - is immutable, and can be used with insert, retract, fire-rules, and query functions. - - If no sources are provided, it will attempt to load rules from the caller's namespace, - which is determined by reading Clojure's *ns* var. - - This will use rules defined with defrule, queries defined with defquery, and sequences - of rule and/or query structures in vars that are annotated with the metadata ^:production-seq. - - The caller may also specify keyword-style options at the end of the parameters. Currently five - options are supported, although most users will either not need these or just the first two: - - * :fact-type-fn, which must have a value of a function used to determine the logical type of a given - fact. Defaults to Clojure's type function. - * :cache, indicating whether the session creation can be cached, effectively memoizing mk-session. - Defaults to true. Callers may wish to set this to false when needing to dynamically reload rules. - * :ancestors-fn, which returns a collection of ancestors for a given type. Defaults to Clojure's ancestors function. A - fact of a given type will match any rule that uses one of that type's ancestors. Note that if the collection is ordered - this ordering will be maintained by Clara; ordering the ancestors consistently will increase the consistency of overall performance. - * :activation-group-fn, a function applied to production structures and returns the group they should be activated with. - It defaults to checking the :salience property, or 0 if none exists. - * :activation-group-sort-fn, a comparator function used to sort the values returned by the above :activation-group-fn. - Defaults to >, so rules with a higher salience are executed first. - * :forms-per-eval - The maximum number of expressions that will be evaluated per call to eval. - Larger batch sizes should see better performance compared to smaller batch sizes. (Only applicable to Clojure) - Defaults to 5000, see clara.rules.compiler/forms-per-eval-default for more information. - * :omit-compile-ctx - When false Clara, in Clojure, retains additional information to improve error messages during - session deserialization at the cost of additional memory use. - By default this information is retained until the session is initially compiled and then will be discarded. This - information might prove useful for debugging compilation errors within the rulebase, eg. rulebase serialization - (ie. via Clara's durability support). - Defaults to true, see clara.rules.compiler/omit-compile-ctx-default for more information. - - This is not supported in ClojureScript, since it requires eval to dynamically build a session. ClojureScript - users must use pre-defined rule sessions using defsession." - [& args] - (if (and (seq args) (not (keyword? (first args)))) - `(com/mk-session ~(vec args)) ; At least one namespace given, so use it. - `(com/mk-session (concat [(ns-name *ns*)] ~(vec args)))))) ; No namespace given, so use the current one. - -#?(:clj - (defmacro defsession - "Creates a sesson given a list of sources and keyword-style options, which are typically Clojure namespaces. - - Typical usage would be like this, with a session defined as a var: - - (defsession my-session 'example.namespace) - - That var contains an immutable session that then can be used as a starting point to create sessions with - caller-provided data. Since the session itself is immutable, it can be safely used from multiple threads - and will not be modified by callers. So a user might grab it, insert facts, and otherwise - use it as follows: - - (-> my-session - (insert (->Temperature 23)) - (fire-rules))" - [name & sources-and-options] - (if (com/compiling-cljs?) - `(clara.macros/defsession ~name ~@sources-and-options) - `(def ~name (com/mk-session ~(vec sources-and-options)))))) - -#?(:clj - (defmacro defrule - "Defines a rule and stores it in the given var. For instance, a simple rule would look like this: - - (defrule hvac-approval - \"HVAC repairs need the appropriate paperwork, so insert - a validation error if approval is not present.\" - [WorkOrder (= type :hvac)] - [:not [ApprovalForm (= formname \"27B-6\")]] - => - (insert! (->ValidationError - :approval - \"HVAC repairs must include a 27B-6 form.\"))) - -See the [rule authoring documentation](http://www.clara-rules.org/docs/rules/) for details." - [name & body] - (if (com/compiling-cljs?) - `(clara.macros/defrule ~name ~@body) - (let [doc (if (string? (first body)) (first body) nil)] - `(def ~(vary-meta name assoc :rule true :doc doc) - ~(dsl/build-rule name body (meta &form))))))) - -#?(:clj - (defmacro defquery - "Defines a query and stored it in the given var. For instance, a simple query that accepts no -parameters would look like this: - - (defquery check-job - \"Checks the job for validation errors.\" - [] - [?issue <- ValidationError]) - -See the [query authoring documentation](http://www.clara-rules.org/docs/queries/) for details." - [name & body] - (if (com/compiling-cljs?) - `(clara.macros/defquery ~name ~@body) - (let [doc (if (string? (first body)) (first body) nil) - binding (if doc (second body) (first body)) - definition (if doc (drop 2 body) (rest body) )] - `(def ~(vary-meta name assoc :query true :doc doc) - ~(dsl/build-query name body (meta &form))))))) - -#?(:clj - (defmacro clear-ns-productions! - "Ensures that any rule/query definitions which have been cached will be cleared from the associated namespace. - Rule and query definitions can be cached such that if their definitions are not explicitly overwritten with the same - name (i.e. deleted or renamed), the stale definitions can be loaded into a session using that namespace on - reload via the REPL or mechanism such as figwheel. Place (clear-ns-productions!) at the top of any namespace - defining rules/queries to ensure the cache is cleared properly." - [] - (if (com/compiling-cljs?) - `(clara.macros/clear-ns-productions!) - (let [production-syms (->> (ns-interns *ns*) - (filter (comp var? second)) - (filter (comp (some-fn :rule :query :production-seq) meta second)) ; Filter down to rules, queries, and seqs of both. - (map first) ; Take the symbols for the rule/query vars - )] - (doseq [psym production-syms] - (ns-unmap *ns* psym)))))) diff --git a/src/main/clojure/clara/rules/accumulators.cljc b/src/main/clojure/clara/rules/accumulators.clj similarity index 89% rename from src/main/clojure/clara/rules/accumulators.cljc rename to src/main/clojure/clara/rules/accumulators.clj index ad6210c0..f71b1663 100644 --- a/src/main/clojure/clara/rules/accumulators.cljc +++ b/src/main/clojure/clara/rules/accumulators.clj @@ -1,7 +1,6 @@ (ns clara.rules.accumulators "A set of common accumulators usable in Clara rules." (:require [clara.rules.engine :as eng] - [clojure.set :as set] [schema.core :as s]) (:refer-clojure :exclude [min max distinct count])) @@ -80,23 +79,24 @@ :convert-return-fn convert-return-fn} combine-fn (assoc :combine-fn combine-fn))))) -(let [grouping-fn (fnil conj [])] - (defn grouping-by - "Return a generic grouping accumulator. Behaves like clojure.core/group-by. +(def ^:private grouping-fn (fnil conj [])) + +(defn grouping-by + "Return a generic grouping accumulator. Behaves like clojure.core/group-by. * `field` - required - The field of a fact to group by. * `convert-return-fn` - optional - Converts the resulting grouped data. Defaults to clojure.core/identity." - ([field] - (grouping-by field identity)) - ([field convert-return-fn] - {:pre [(ifn? convert-return-fn)]} - (reduce-to-accum - (fn [m x] - (let [v (field x)] - (update m v grouping-fn x))) - {} - convert-return-fn)))) + ([field] + (grouping-by field identity)) + ([field convert-return-fn] + {:pre [(ifn? convert-return-fn)]} + (reduce-to-accum + (fn [m x] + (let [v (field x)] + (update m v grouping-fn x))) + {} + convert-return-fn))) (defn- comparison-based "Creates a comparison-based result such as min or max" @@ -151,13 +151,13 @@ (defn sum "Returns an accumulator that returns the sum of values of a given field" - [field] + [field & {:keys [default-value] :or {default-value 0}}] (accum {:initial-value 0 :reduce-fn (fn [total item] - (+ total (field item))) + (+ total (or (field item) default-value))) :retract-fn (fn [total item] - (- total (field item))) + (- total (or (field item) default-value))) :combine-fn +})) (defn count @@ -202,12 +202,12 @@ "Returns an accumulator that preserves all accumulated items. If given a field, returns all values in that field." ([] - (accum - {:initial-value [] - :reduce-fn (fn [items value] (conj items value)) - :retract-fn (fn [items retracted] (drop-one-of items retracted))})) + (accum + {:initial-value [] + :reduce-fn (fn [items value] (conj items value)) + :retract-fn (fn [items retracted] (drop-one-of items retracted))})) ([field] - (accum - {:initial-value [] - :reduce-fn (fn [items value] (conj items (field value))) - :retract-fn (fn [items retracted] (drop-one-of items (field retracted)))}))) + (accum + {:initial-value [] + :reduce-fn (fn [items value] (conj items (field value))) + :retract-fn (fn [items retracted] (drop-one-of items (field retracted)))}))) diff --git a/src/main/clojure/clara/rules/compiler.clj b/src/main/clojure/clara/rules/compiler.clj index cd1f2903..394d4f46 100644 --- a/src/main/clojure/clara/rules/compiler.clj +++ b/src/main/clojure/clara/rules/compiler.clj @@ -4,11 +4,19 @@ Most users should use only the clara.rules namespace." (:require [clara.rules.engine :as eng] [clara.rules.schema :as schema] + [clara.rules.platform :refer [jeq-wrap] :as platform] + [clojure.core.cache.wrapped :as cache] + [ham-fisted.api :as hf] + [ham-fisted.set :as hs] + [ham-fisted.mut-map :as hm] + [futurama.util :as u] [clojure.set :as set] [clojure.string :as string] [clojure.walk :as walk] [schema.core :as sc]) - (:import [clara.rules.engine + (:import [clara.rules.platform + JavaEqualityWrapper] + [clara.rules.engine ProductionNode QueryNode AlphaNode @@ -22,15 +30,40 @@ AccumulateWithJoinFilterNode LocalTransport Accumulator + NegationResult ISystemFact] [java.beans PropertyDescriptor] [clojure.lang IFn])) -;; Protocol for loading rules from some arbitrary source. -(defprotocol IRuleSource - (load-rules [source])) +;; Cache of sessions for fast reloading. +(defonce default-session-cache + (cache/lru-cache-factory {})) + +;; Cache of compiled expressions +(defonce default-compiler-cache + (cache/soft-cache-factory {})) + +(defn clear-session-cache! + "Clears the cache of reusable Clara sessions, so any subsequent sessions + will be re-compiled from the rule definitions. This is intended for use + by tooling or specialized needs; most users can simply specify the :cache false + option when creating sessions." + [] + (swap! default-session-cache empty)) + +(defn clear-compiler-cache! + "Clears the default compiler cache of re-usable compiled expressions, so any + subsequent expressions will be re-compiled. This is intended for use by tooling + or during testing; most users can simply specify the :compiler-cache false + option when creating sessions." + [] + (swap! default-compiler-cache empty)) + +;; Protocol for loading a source of rules and fact hierarchies. +(defprotocol IClaraSource + (load-source [source])) (sc/defschema BetaNode "These nodes exist in the beta network." @@ -61,8 +94,8 @@ query-nodes :- {sc/Any QueryNode} ;; Map of id to one of the alpha or beta nodes (join, accumulate, etc). id-to-node :- {sc/Num (sc/conditional - :activation AlphaNode - :else BetaNode)} + :activation AlphaNode + :else BetaNode)} ;; Function for sorting activation groups of rules for firing. activation-group-sort-fn ;; Function that takes a rule and returns its activation group. @@ -78,79 +111,6 @@ (and (symbol? expr) (.startsWith (name expr) "?"))) -(def ^:private reflector - "For some reason (bug?) the default reflector doesn't use the - Clojure dynamic class loader, which prevents reflecting on - `defrecords`. Work around by supplying our own which does." - (clojure.reflect.JavaReflector. (clojure.lang.RT/makeClassLoader))) - -;; This technique borrowed from Prismatic's schema library. -(defn compiling-cljs? - "Return true if we are currently generating cljs code. Useful because cljx does not - provide a hook for conditional macro expansion." - [] - (boolean - (when-let [n (find-ns 'cljs.analyzer)] - (when-let [v (ns-resolve n '*cljs-file*)] - - ;; We perform this require only if we are compiling ClojureScript - ;; so non-ClojureScript users do not need to pull in - ;; that dependency. - (require 'clara.macros) - @v)))) - -(defn get-namespace-info - "Get metadata about the given namespace." - [namespace] - (when-let [n (and (compiling-cljs?) (find-ns 'cljs.env))] - (when-let [v (ns-resolve n '*compiler*)] - (get-in @@v [ :cljs.analyzer/namespaces namespace])))) - -(defn cljs-ns - "Returns the ClojureScript namespace being compiled during Clojurescript compilation." - [] - (if (compiling-cljs?) - (-> 'cljs.analyzer (find-ns) (ns-resolve '*cljs-ns*) deref) - nil)) - -(defn resolve-cljs-sym - "Resolves a ClojureScript symbol in the given namespace." - [ns-sym sym] - (let [ns-info (get-namespace-info ns-sym)] - (if (namespace sym) - - ;; Symbol qualified by a namespace, so look it up in the requires info. - (if-let [source-ns (get-in ns-info [:requires (symbol (namespace sym))])] - (symbol (name source-ns) (name sym)) - ;; Not in the requires block, so assume the qualified name is a refers and simply return the symbol. - sym) - - ;; Symbol is unqualified, so check in the uses block. - (if-let [source-ns (get-in ns-info [:uses sym])] - (symbol (name source-ns) (name sym)) - - ;; Symbol not found in eiher block, so attempt to retrieve it from - ;; the current namespace. - (if (get-in (get-namespace-info ns-sym) [:defs sym]) - (symbol (name ns-sym) (name sym)) - nil))))) - -(defn- get-cljs-accessors - "Returns accessors for ClojureScript. WARNING: this touches - ClojureScript implementation details that may change." - [sym] - (let [resolved (resolve-cljs-sym (cljs-ns) sym) - constructor (symbol (str "->" (name resolved))) - namespace-info (get-namespace-info (symbol (namespace resolved))) - constructor-info (get-in namespace-info [:defs constructor])] - - (if constructor-info - (into {} - (for [field (first (:method-params constructor-info))] - [field (keyword (name field))])) - []))) - - (defn- get-field-accessors "Given a clojure.lang.IRecord subclass, returns a map of field name to a symbol representing the function used to access it." @@ -180,31 +140,26 @@ [(symbol (string/replace (.getName property) #"_" "-")) ; Replace underscore with idiomatic dash. (symbol (str "." (.getName read-method)))]))) -(defn effective-type [type] - (if (compiling-cljs?) - type +(defn- effective-type* + [type] + (if (symbol? type) + (clojure.lang.RT/classForName ^String (name type)) + type)) - (if (symbol? type) - (.loadClass (clojure.lang.RT/makeClassLoader) (name type)) - type))) +(def effective-type + (memoize effective-type*)) -(defn get-fields +(defn- get-fields* "Returns a map of field name to a symbol representing the function used to access it." [type] - (if (compiling-cljs?) - - ;; Get ClojureScript fields. - (if (symbol? type) - (get-cljs-accessors type) - []) - - ;; Attempt to load the corresponding class for the type if it's a symbol. - (let [type (effective-type type)] + (let [type (effective-type type)] + (cond + (isa? type clojure.lang.IRecord) (get-field-accessors type) + (class? type) (get-bean-accessors type) ; Treat unrecognized classes as beans. + :else []))) - (cond - (isa? type clojure.lang.IRecord) (get-field-accessors type) - (class? type) (get-bean-accessors type) ; Treat unrecognized classes as beans. - :default [])))) +(def get-fields + (memoize get-fields*)) (defn- equality-expression? [expression] (let [qualify-when-sym #(when-let [resolved (and (symbol? %) @@ -250,16 +205,16 @@ (if (empty? exp-seq) '?__bindings__ - (let [ [exp & rest-exp] exp-seq - variables (into #{} - (filter (fn [item] - (and (symbol? item) - (= \? (first (name item))) - (not (equality-only-variables item)))) - exp)) - expression-values (remove variables (rest exp)) - binds-variables? (and (equality-expression? exp) - (seq variables)) + (let [[exp & rest-exp] exp-seq + variables (into #{} + (filter (fn [item] + (and (symbol? item) + (= \? (first (name item))) + (not (equality-only-variables item)))) + exp)) + expression-values (remove variables (rest exp)) + binds-variables? (and (equality-expression? exp) + (seq variables)) ;; if we intend on binding any variables at this level of the ;; expression then future layers should not be able to rebind them. @@ -297,14 +252,12 @@ ;; equal. ~(if (> (count expression-values) 1) - `(if ~(cons '= expression-values) ~compiled-rest nil) ;; No additional values to check, so move on to the rest of ;; the expression - compiled-rest) - ) + compiled-rest)) - ;; A contraint that is empty doesn't need to be added as a check, +;; A contraint that is empty doesn't need to be added as a check, ;; simply move on to the rest (empty? exp) compiled-rest @@ -314,7 +267,6 @@ :else `(if ~exp ~compiled-rest nil)))))) - (defn flatten-expression "Flattens expression as clojure.core/flatten does, except will flatten anything that is a collection rather than specifically sequential." @@ -359,7 +311,7 @@ (vary-meta fact-symbol assoc :tag (symbol (.getName ^Class fact-type))) fact-symbol))) -(defn- mk-node-fn-name +(defn mk-node-fn-name "A simple helper function to maintain a consistent pattern for naming anonymous functions in the rulebase. node-type - expected to align with one of the types of nodes defined in clara.rules.engine, and node-type->abbreviated-type. @@ -370,7 +322,7 @@ filter functions." [node-type node-id fn-type] (if-let [abbreviated-node-type (get eng/node-type->abbreviated-type node-type)] - (symbol (str abbreviated-node-type "-" node-id "-" fn-type)) + (with-meta (symbol (str abbreviated-node-type "-" fn-type)) {:node-id node-id}) (throw (ex-info "Unrecognized node type" {:node-type node-type :node-id node-id @@ -401,7 +353,6 @@ ;; Hardcoding the node-type and fn-type as we would only ever expect 'compile-condition' to be used for this scenario fn-name (mk-node-fn-name "AlphaNode" node-id "AE")] - `(fn ~fn-name [~(add-meta '?__fact__ type) ~destructured-env] (let [~@assignments @@ -431,9 +382,8 @@ (defn compile-test [node-id constraints env] (compile-test-handler node-id constraints env)) -(defn compile-action - "Compile the right-hand-side action of a rule, returning a function to execute it." - [node-id binding-keys rhs env] +(defn compile-action-handler + [action-name binding-keys rhs env] (let [;; Avoid creating let bindings in the compile code that aren't actually used in the body. ;; The bindings only exist in the scope of the RHS body, not in any code called by it, ;; so this scanning strategy will detect all possible uses of binding variables in the RHS. @@ -441,25 +391,30 @@ ;; we're trying to support. If necessary a user could macroexpand their RHS code manually before ;; providing it to Clara. rhs-bindings-used (variables-as-keywords rhs) - token-binding-keys (sequence - (filter rhs-bindings-used) - binding-keys) + (filter rhs-bindings-used) + binding-keys) ;; The destructured environment, if any. - destructured-env (if (> (count env) 0) - {:keys (mapv #(symbol (name %)) (keys env))} + destructured-env (if (pos? (count env)) + {:keys (mapv (comp symbol name) (keys env)) :as '?__env__} '?__env__) - - ;; Hardcoding the node-type and fn-type as we would only ever expect 'compile-action' to be used for this scenario - fn-name (mk-node-fn-name "ProductionNode" node-id "AE")] - `(fn ~fn-name [~'?__token__ ~destructured-env] + destructured-bindings (if (pos? (count token-binding-keys)) + {{:keys (mapv (comp symbol name) token-binding-keys)} :bindings + :as '?__token__} + '?__token__)] + `(fn ~action-name [~destructured-bindings ~destructured-env] ;; similar to test nodes, nothing in the contract of an RHS enforces that bound variables must be used. ;; similarly we will not bind anything in this event, and thus the let block would be superfluous. - ~(if (seq token-binding-keys) - `(let [{:keys [~@(map (comp symbol name) token-binding-keys)]} (:bindings ~'?__token__)] - ~rhs) - rhs)))) + ~rhs))) + +(defn compile-action + "Compile the right-hand-side action of a rule, returning a function to execute it." + [node-id binding-keys rhs env] + (let [;; Hardcoding the node-type and fn-type as we would only ever expect 'compile-action' to be used for this scenario + fn-name (mk-node-fn-name "ProductionNode" node-id "AE") + handler (compile-action-handler fn-name binding-keys rhs env)] + `~handler)) (defn compile-accum "Used to create accumulators that take the environment into account." @@ -476,14 +431,14 @@ (defn compile-join-filter "Compiles to a predicate function that ensures the given items can be unified. Returns a ready-to-eval - function that accepts the following: + function that accepts the following: - * a token from the parent node - * the fact - * a map of bindings from the fact, which was typically computed on the alpha side - * an environment + * a token from the parent node + * the fact + * a map of bindings from the fact, which was typically computed on the alpha side + * an environment - The function created here returns truthy if the given fact satisfies the criteria." + The function created here returns truthy if the given fact satisfies the criteria." [node-id node-type {:keys [type constraints args] :as unification-condition} ancestor-bindings element-bindings env] (let [accessors (field-name->accessors-used type constraints) @@ -512,18 +467,17 @@ ;; JFE will stand for JoinFilterExpr fn-name (mk-node-fn-name node-type node-id "JFE")] - `(fn ~fn-name [~'?__token__ - ~(add-meta '?__fact__ type) - ~'?__element-bindings__ - ~destructured-env] + ~(add-meta '?__fact__ type) + ~'?__element-bindings__ + ~destructured-env] (let [~@fact-assignments ;; We should always have some form of bound variables here, however in the event that we ever didn't ;; there would be no need to generate non-existent bindings. - ~@(if (seq element-bindings) - [{:keys (mapv (comp symbol name) element-bindings)} '?__element-bindings__]) - ~@(if (seq token-binding-keys) + ~@(when (seq element-bindings) + [{:keys (mapv (comp symbol name) element-bindings)} '?__element-bindings__]) + ~@(when (seq token-binding-keys) [{:keys (mapv (comp symbol name) token-binding-keys)} (list :bindings '?__token__)]) ~'?__bindings__ {}] ~(compile-constraints constraints equality-only-variables))))) @@ -640,8 +594,8 @@ (when (and (seq? form) (not (equality-expression? form)) (some (fn [sym] (and (symbol? sym) - (.startsWith (name sym) "?") - (not (previously-bound sym)))) + (.startsWith (name sym) "?") + (not (previously-bound sym)))) (flatten-expression form))) (reset! found-complex true)) @@ -662,15 +616,15 @@ accumulator (:accumulator condition) result-binding (:result-binding condition) ; Get the optional result binding used by accumulators. condition (cond - is-negation (second condition) - accumulator (:from condition) - :default condition) + is-negation (second condition) + accumulator (:from condition) + :else condition) node-type (cond - is-negation :negation - is-exists :exists - accumulator :accumulator - (:type condition) :join - :else :test)] + is-negation :negation + is-exists :exists + accumulator :accumulator + (:type condition) :join + :else :test)] node-type)) @@ -688,9 +642,9 @@ ;; This is an :exists condition, so expand it ;; into an accumulator and a test. (let [exists-count (gensym "?__gen__")] - [{:accumulator '(clara.rules.accumulators/exists) - :from (second condition) - :result-binding (keyword exists-count)}]) + [{:accumulator '(clara.rules.accumulators/exists) + :from (second condition) + :result-binding (keyword exists-count)}]) ;; This is not an :exists condition, so do not change it. [condition])] @@ -750,7 +704,6 @@ ;; Flag indicating it is an accumulator. :is-accumulator sc/Bool} [condition :- schema/Condition] - (let [dnf-condition (to-dnf condition) ;; Break the condition up into leafs @@ -765,8 +718,7 @@ [nested-condition])] leaf-condition) - - ;; A top level and of nested conditions, so just use them +;; A top level and of nested conditions, so just use them :and (rest dnf-condition) @@ -776,13 +728,12 @@ (reduce (fn [{:keys [bound unbound condition is-accumulator]} leaf-condition] - - ;; The effective leaf for variable purposes may be contained in a negation or +;; The effective leaf for variable purposes may be contained in a negation or ;; an accumulator, so extract it. (let [effective-leaf (condp = (condition-type leaf-condition) - :accumulator (:from leaf-condition) - :negation (second leaf-condition) - leaf-condition) + :accumulator (:from leaf-condition) + :negation (second leaf-condition) + leaf-condition) constraints (:constraints effective-leaf) @@ -826,7 +777,6 @@ "Performs a topologic sort of conditions to ensure variables needed by child conditions are bound." [conditions :- [schema/Condition]] - ;; Get the bound and unbound variables for all conditions and sort them. (let [classified-conditions (map analyze-condition conditions)] @@ -871,8 +821,8 @@ ;; Get the subset of variables that cannot be satisfied. (let [unsatisfiable (set/difference - (apply set/union (map :unbound still-unsatisfied)) - bound-variables)] + (apply set/union (map :unbound still-unsatisfied)) + bound-variables)] (throw (ex-info (str "Using variable that is not previously bound. This can happen " "when an expression uses a previously unbound variable, " "or if a variable is referenced in a nested part of a parent " @@ -894,7 +844,7 @@ "Returns a set of unifications that do not use equality-based checks." [constraints] (let [[bound-variables unbound-variables] (classify-variables constraints)] - (into #{} + (into (hs/set) (for [constraint constraints :when (non-equality-unification? constraint bound-variables)] constraint)))) @@ -908,9 +858,9 @@ accumulator (:accumulator condition) result-binding (:result-binding condition) ; Get the optional result binding used by accumulators. condition (cond - (= :negation node-type) (second condition) - accumulator (:from condition) - :default condition) + (= :negation node-type) (second condition) + accumulator (:from condition) + :else condition) ;; Convert a test within a negation to a negation of the test. This is necessary ;; because negation nodes expect an additional condition to match against. @@ -928,21 +878,21 @@ (= :negation node-type) (= :join node-type)) (non-equality-unifications (:constraints condition)) - #{}) + (hs/set)) ;; If there are any non-equality unitifications, create a join with filter expression to handle them. join-filter-expressions (if (seq non-equality-unifications) - (assoc condition :constraints (filterv non-equality-unifications (:constraints condition))) + (assoc condition :constraints (filterv non-equality-unifications (:constraints condition))) - nil) + nil) ;; Remove instances of non-equality constraints from accumulator ;; and negation nodes, since those are handled with specialized node implementations. condition (if (seq non-equality-unifications) (assoc condition - :constraints (into [] (remove non-equality-unifications (:constraints condition))) - :original-constraints (:constraints condition)) + :constraints (into [] (remove non-equality-unifications (:constraints condition))) + :original-constraints (:constraints condition)) condition) @@ -955,93 +905,76 @@ constraint-bindings) new-bindings (set/difference (variables-as-keywords (:constraints condition)) - parent-bindings) + parent-bindings) join-filter-bindings (if join-filter-expressions (variables-as-keywords join-filter-expressions) nil)] - (cond-> - {:node-type node-type + (cond-> {:node-type node-type :condition condition :new-bindings new-bindings :used-bindings (set/union cond-bindings join-filter-bindings)} + (seq env) (assoc :env env) - (seq env) (assoc :env env) - - ;; Add the join bindings to join, accumulator or negation nodes. - (#{:join :negation :accumulator} node-type) (assoc :join-bindings (set/intersection cond-bindings parent-bindings)) + ;; Add the join bindings to join, accumulator or negation nodes. + (#{:join :negation :accumulator} node-type) (assoc :join-bindings (set/intersection cond-bindings parent-bindings)) - accumulator (assoc :accumulator accumulator) + accumulator (assoc :accumulator accumulator) - result-binding (assoc :result-binding result-binding) + result-binding (assoc :result-binding result-binding) - join-filter-expressions (assoc :join-filter-expressions join-filter-expressions) + join-filter-expressions (assoc :join-filter-expressions join-filter-expressions) - join-filter-bindings (assoc :join-filter-join-bindings (set/intersection join-filter-bindings parent-bindings))))) + join-filter-bindings (assoc :join-filter-join-bindings (set/intersection join-filter-bindings parent-bindings))))) (sc/defn ^:private add-node :- schema/BetaGraph "Adds a node to the beta graph." [beta-graph :- schema/BetaGraph source-ids :- [sc/Int] target-id :- sc/Int - target-node :- (sc/either schema/ConditionNode schema/ProductionNode)] + target-node :- (sc/conditional + (comp #{:production :query} :node-type) schema/ProductionNode + :else schema/ConditionNode)] + (hf/assoc! (:id-to-new-bindings beta-graph) target-id + ;; A ProductionNode will not have the set of new bindings previously created, + ;; so we assign them an empty set here. A ConditionNode will always have a set of new bindings, + ;; even if it is an empty one; this is enforced by the schema. Having an empty set of new bindings + ;; is a valid and meaningful state that just means that all join bindings in that node come from right-activations + ;; earlier in the network. + (or (:new-bindings target-node) + (hs/set))) + (if (#{:production :query} (:node-type target-node)) + (hf/assoc! (:id-to-production-node beta-graph) target-id target-node) + (hf/assoc! (:id-to-condition-node beta-graph) target-id target-node)) ;; Add the production or condition to the network. - (let [beta-graph (assoc-in beta-graph [:id-to-new-bindings target-id] - ;; A ProductionNode will not have the set of new bindings previously created, - ;; so we assign them an empty set here. A ConditionNode will always have a set of new bindings, - ;; even if it is an empty one; this is enforced by the schema. Having an empty set of new bindings - ;; is a valid and meaningful state that just means that all join bindings in that node come from right-activations - ;; earlier in the network. - (or (:new-bindings target-node) - #{})) - - beta-graph (if (#{:production :query} (:node-type target-node)) - (assoc-in beta-graph [:id-to-production-node target-id] target-node) - (assoc-in beta-graph [:id-to-condition-node target-id] target-node))] - - - ;; Associate the forward and backward edges. - (reduce (fn [beta-graph source-id] - (let [forward-path [:forward-edges source-id] - forward-previous (get-in beta-graph forward-path) - backward-path [:backward-edges target-id] - backward-previous (get-in beta-graph backward-path)] - (-> beta-graph - (assoc-in - forward-path - (if forward-previous - (conj forward-previous target-id) - (sorted-set target-id))) - (assoc-in - backward-path - (if backward-previous - (conj backward-previous source-id) - (sorted-set source-id)))))) - - beta-graph - source-ids))) - + ;; Associate the forward and backward edges. + (doseq [source-id source-ids] + (hm/compute! (:forward-edges beta-graph) source-id + (fn [_ forward-previous] + (if forward-previous + (conj forward-previous target-id) + (sorted-set target-id)))) + (hm/compute! (:backward-edges beta-graph) target-id + (fn [_ backward-previous] + (if backward-previous + (conj backward-previous source-id) + (sorted-set source-id))))) + beta-graph) (declare add-production) -(sc/defn ^:private extract-negation :- {:new-expression schema/Condition - :beta-with-negations schema/BetaGraph} - - "Extracts complex, nested negations and adds a rule to the beta graph to trigger the returned - negation expression." +(sc/defn ^:private get-complex-negation :- (sc/maybe + {:new-expression schema/Condition + :generated-rule schema/Production}) [previous-expressions :- [schema/Condition] expression :- schema/Condition - parent-ids :- [sc/Int] ancestor-bindings :- #{sc/Keyword} - beta-graph :- schema/BetaGraph - production :- schema/Production - create-id-fn] - - (if (and (= :not (first expression)) - (sequential? (second expression)) - (#{:and :or :not} (first (second expression)))) + production :- schema/Production] + (when (and (= :not (first expression)) + (sequential? (second expression)) + (#{:and :or :not} (first (second expression)))) ;; Dealing with a compound negation, so extract it out. (let [negation-expr (second expression) @@ -1057,8 +990,8 @@ ;; See https://github.com/cerner/clara-rules/issues/304 for more details ;; and a case that behaves incorrectly without this check. ancestor-bindings-in-negation-expr (set/intersection - (variables-as-keywords negation-expr) - ancestor-bindings) + (variables-as-keywords negation-expr) + ancestor-bindings) ancestor-bindings-insertion-form (into {} (map (fn [binding] @@ -1071,9 +1004,7 @@ (list '= (-> b name symbol) (list b 'ancestor-bindings))) - modified-expression `[:not {:type ~(if (compiling-cljs?) - 'clara.rules.engine/NegationResult - 'clara.rules.engine.NegationResult) + modified-expression `[:not {:type NegationResult :constraints [(~'= ~gen-rule-name ~'gen-rule-name) ~@(map ancestor-binding->restriction-form ancestor-bindings-in-negation-expr)]}] @@ -1089,26 +1020,56 @@ true (assoc-in [:props :clara-rules/internal-salience] :extracted-negation) ;; Propagate the the environment (such as local bindings) if applicable. - (:env production) (assoc :env (:env production))) - - ;; Add the generated rule to the beta network. + (:env production) (assoc :env (:env production)))] + {:new-expression modified-expression + :generated-rule generated-rule}))) +(sc/defn ^:private add-complex-negation :- (sc/maybe + {:new-expression schema/Condition + :beta-with-negations schema/BetaGraph}) - beta-with-negations (add-production generated-rule beta-graph create-id-fn)] + "Extracts complex, nested negations and adds a rule to the beta graph to trigger the returned + negation expression." + [previous-expressions :- [schema/Condition] + expression :- schema/Condition + ancestor-bindings :- #{sc/Keyword} + beta-graph :- schema/BetaGraph + production :- schema/Production + create-id-fn] + (when-let [{:keys [new-expression + generated-rule]} (get-complex-negation previous-expressions expression + ancestor-bindings production)] + ;; The expression was a negation, so add it to the Beta graph + {:new-expression new-expression + :beta-with-negations (add-production generated-rule beta-graph create-id-fn)})) - {:new-expression modified-expression - :beta-with-negations beta-with-negations}) +;; A beta graph with no nodes. +(defn ^:private empty-beta-graph + [] + {:forward-edges (hf/mut-long-map) + :backward-edges (hf/mut-long-map) + :id-to-condition-node (hf/mut-long-map {0 ::root-condition}) + :id-to-production-node (hf/mut-long-map) + :id-to-new-bindings (hf/mut-long-map)}) + +(sc/defn ^:private get-condition-bindings :- {:bindings #{sc/Keyword}} + "Get the bindings from a sequence of condition/conjunctions." + [conditions :- [schema/Condition] + env :- (sc/maybe {sc/Keyword sc/Any}) + ancestor-bindings :- #{sc/Keyword}] + (loop [bindings ancestor-bindings + [expression & remaining-expressions] conditions] + (if expression + (let [node (condition-to-node expression env bindings) - ;; The expression wasn't a negation, so return the previous content. - {:new-expression expression - :beta-with-negations beta-graph})) + {:keys [result-binding fact-binding]} expression -;; A beta graph with no nodes. -(def ^:private empty-beta-graph {:forward-edges (sorted-map) - :backward-edges (sorted-map) - :id-to-condition-node (sorted-map 0 ::root-condition) - :id-to-production-node (sorted-map) - :id-to-new-bindings (sorted-map)}) + all-bindings (cond-> (set/union bindings (:used-bindings node)) + result-binding (conj result-binding) + fact-binding (conj fact-binding))] + (recur all-bindings remaining-expressions)) + ;; No expressions remaining, so return the structure. + {:bindings bindings}))) (sc/defn ^:private add-conjunctions :- {:beta-graph schema/BetaGraph :new-ids [sc/Int] @@ -1122,7 +1083,6 @@ ancestor-bindings :- #{sc/Keyword} beta-graph :- schema/BetaGraph create-id-fn] - (loop [beta-graph beta-graph parent-ids parent-ids bindings ancestor-bindings @@ -1149,7 +1109,7 @@ vals ;; Order doesn't matter here as we will effectively sort it using update-node->id later, ;; thus adding determinism. - (into #{} cat))) + (into (hs/set) cat))) id-to-condition-nodes (:id-to-condition-node beta-graph) @@ -1165,20 +1125,18 @@ ;; all of the old children for a prior match, for each additional child added we incur the assoc but the hash code ;; has already been cached by prior iterations of add-conjunctions. In these cases we have seen that the hashing ;; will out perform equivalence checks. - update-node->ids (fn [m id] - (let [node (get id-to-condition-nodes id) - prev (get m node)] - (if prev - ;; There might be nodes with multiple representation under the same parent, this would - ;; likely be due to nodes that have the same condition but do not share all the same - ;; parents, see Issue 433 for more information - (assoc! m node (conj prev id)) - (assoc! m node [id])))) - - node->ids (-> (reduce update-node->ids - (transient {}) - forward-edges) - persistent!) + update-node->ids (fn update-node-ids [m id] + (hm/compute! m (get id-to-condition-nodes id) + (fn do-update-node-ids + [_ node-ids] + (if node-ids + (conj node-ids id) + [id]))) + m) + + node->ids (reduce update-node->ids + (hf/mut-hashtable-map) + forward-edges) backward-edges (:backward-edges beta-graph) @@ -1196,7 +1154,6 @@ graph-with-node (add-node beta-graph parent-ids node-id node)] - (recur graph-with-node [node-id] all-bindings @@ -1207,6 +1164,73 @@ :new-ids parent-ids :bindings bindings}))) +(sc/defn build-rule-node :- schema/ProductionNode + [production :- schema/Production] + (when (:rhs production) + (let [flattened-conditions (for [condition (:lhs production) + child-condition (if (#{'and :and} (first condition)) + (rest condition) + [condition])] + + child-condition) + + sorted-conditions (sort-conditions flattened-conditions) + + {ancestor-bindings :bindings} + (loop [previous-conditions [] + [current-condition & remaining-conditions] sorted-conditions + ancestor-bindings #{}] + (if-not current-condition + {:bindings ancestor-bindings} + (let [{:keys [new-expression]} + (get-complex-negation previous-conditions + current-condition + ancestor-bindings + production) + + condition (or new-expression + current-condition) + + ;; Extract disjunctions from the condition. + dnf-expression (to-dnf condition) + + ;; Get a sequence of disjunctions. + disjunctions (for [expression + (if (= :or (first dnf-expression)) ; Ignore top-level or in DNF. + (rest dnf-expression) + [dnf-expression])] + + (if (= :and (first expression)) ; Ignore nested ands in DNF. + (rest expression) + [expression])) + + {all-bindings :bindings} + (reduce (fn [previous-result conjunctions] + ;; Get the complete bindings + (let [;; Convert exists operations to accumulator and test nodes. + exists-extracted (extract-exists conjunctions) + ;; Compute the new bindings with the expressions. + new-result (get-condition-bindings exists-extracted + (:env production) + ancestor-bindings)] + + ;; Combine the bindings + ;; for use in descendent nodes. + {:bindings (set/union (:bindings previous-result) + (:bindings new-result))})) + + ;; Initial reduce value, combining previous graph, parent ids, and ancestor variable bindings. + {:bindings ancestor-bindings} + + ;; Each disjunction contains a sequence of conjunctions. + disjunctions)] + (recur (conj previous-conditions current-condition) + remaining-conditions + all-bindings))))] + {:node-type :production + :production production + :bindings ancestor-bindings}))) + (sc/defn ^:private add-production :- schema/BetaGraph "Adds a production to the graph of beta nodes." [production :- schema/Production @@ -1232,16 +1256,16 @@ (if current-condition (let [{:keys [new-expression beta-with-negations]} - (extract-negation previous-conditions - current-condition - parent-ids - ancestor-bindings - beta-graph - production - create-id-fn) + (add-complex-negation previous-conditions + current-condition + ancestor-bindings + beta-graph + production + create-id-fn) + + beta-graph (or beta-with-negations beta-graph) - condition (or new-expression - current-condition) + condition (or new-expression current-condition) ;; Extract disjunctions from the condition. dnf-expression (to-dnf condition) @@ -1279,7 +1303,7 @@ (:bindings new-result))})) ;; Initial reduce value, combining previous graph, parent ids, and ancestor variable bindings. - {:beta-graph beta-with-negations + {:beta-graph beta-graph :new-ids [] :bindings ancestor-bindings} @@ -1314,22 +1338,21 @@ :available-bindings ancestor-bindings :query (:name production)})))))))) - (sc/defn to-beta-graph :- schema/BetaGraph "Produces a description of the beta network." [productions :- #{schema/Production} create-id-fn :- IFn] - (reduce (fn [beta-graph production] - (binding [*compile-ctx* {:production production}] - (add-production production beta-graph create-id-fn))) - - empty-beta-graph - productions)) + (reduce (fn add-to-beta-graph + [beta-graph production] + (binding [*compile-ctx* {:production production}] + (add-production production beta-graph create-id-fn))) + (empty-beta-graph) + productions)) (sc/defn ^:private root-node? :- sc/Bool "A helper function to determine if the node-id provided is a root node. A given node would be considered a root-node, if its only backward edge was that of the artificial root node, node 0." - [backward-edges :- {sc/Int #{sc/Int}} + [backward-edges :- schema/MutableLongHashMap node-id :- sc/Int] (= #{0} (get backward-edges node-id))) @@ -1345,153 +1368,213 @@ alpha-graph :- [schema/AlphaNode]] (let [backward-edges (:backward-edges beta-graph) handle-expr (fn [id->expr s-expr id expr-key compilation-ctx] - (assoc id->expr - [id expr-key] - [s-expr (assoc compilation-ctx expr-key s-expr)])) - - ;; If extract-exprs ever became a hot spot, this could be changed out to use more java interop. - id->expr (reduce (fn [prev alpha-node] - (let [{:keys [id condition env]} alpha-node - {:keys [type constraints fact-binding args]} condition - cmeta (meta condition)] - (handle-expr prev - (with-meta (compile-condition - type id (first args) constraints - fact-binding env) + (hf/assoc! id->expr + [id expr-key] + [s-expr (assoc compilation-ctx expr-key s-expr)]) + id->expr) + + id->expr (reduce (fn add-alpha-nodes + [prev alpha-node] + (let [{:keys [id condition env]} alpha-node + {:keys [type constraints fact-binding args]} condition + cmeta (meta condition)] + (handle-expr prev + (with-meta (compile-condition + type id (first args) constraints + fact-binding env) ;; Remove all metadata but file and line number ;; to protect from evaluating unsafe metadata ;; See PR 243 for more detailed discussion - (select-keys cmeta [:line :file])) + (select-keys cmeta [:line :file])) + id + :alpha-expr + {:file (or (:file cmeta) *file*) + :compile-ctx {:condition condition + :env env + :msg "compiling alpha node"}}))) + (hf/mut-map) + alpha-graph) + id->expr (reduce-kv (fn add-action-nodes + [prev id production-node] + (let [production (-> production-node :production)] + (handle-expr prev + (with-meta (compile-action id + (:bindings production-node) + (:rhs production) + (:env production)) + (meta (:rhs production))) id - :alpha-expr - {:file (or (:file cmeta) *file*) - :compile-ctx {:condition condition - :env env - :msg "compiling alpha node"}}))) - {} - alpha-graph) - id->expr (reduce-kv (fn [prev id production-node] - (let [production (-> production-node :production)] - (handle-expr prev - (with-meta (compile-action id - (:bindings production-node) - (:rhs production) - (:env production)) - (meta (:rhs production))) - id - :action-expr - ;; ProductionNode expressions can be arbitrary code, therefore we need the - ;; ns where the production was define so that we can compile the expression - ;; later. - {:ns (:ns-name production) - :file (-> production :rhs meta :file) - :compile-ctx {:production production - :msg "compiling production node"}}))) + :action-expr + ;; ProductionNode expressions can be arbitrary code, therefore we need the + ;; ns where the production was define so that we can compile the expression + ;; later. + {:ns (:ns-name production) + :file (-> production :rhs meta :file) + :compile-ctx {:production production + :msg "compiling production node"}}))) id->expr - (:id-to-production-node beta-graph))] - (reduce-kv - (fn [prev id beta-node] - (let [condition (:condition beta-node) - condition (if (symbol? condition) - (.loadClass (clojure.lang.RT/makeClassLoader) (name condition)) - condition)] - (case (or (:node-type beta-node) - ;; If there is no :node-type then the node is the ::root-condition - ;; however, creating a case for nil could potentially cause weird effects if something about the - ;; compilation of the beta graph changes. Therefore making an explicit case for ::root-condition - ;; and if there was anything that wasn't ::root-condition this case statement will fail rather than - ;; failing somewhere else. - beta-node) - ::root-condition prev - - :join (if (or (root-node? backward-edges id) - (not (:join-filter-expressions beta-node))) - ;; This is either a RootJoin or HashJoin node, in either case they do not have an expression - ;; to capture. - prev - (handle-expr prev - (compile-join-filter id - "ExpressionJoinNode" - (:join-filter-expressions beta-node) - (:join-filter-join-bindings beta-node) - (:new-bindings beta-node) - (:env beta-node)) - id - :join-filter-expr - {:compile-ctx {:condition condition - :join-filter-expressions (:join-filter-expressions beta-node) - :env (:env beta-node) - :msg "compiling expression join node"}})) - :negation (if (:join-filter-expressions beta-node) - (handle-expr prev - (compile-join-filter id - "NegationWithJoinFilterNode" - (:join-filter-expressions beta-node) - (:join-filter-join-bindings beta-node) - (:new-bindings beta-node) - (:env beta-node)) - id - :join-filter-expr - {:compile-ctx {:condition condition - :join-filter-expressions (:join-filter-expressions beta-node) - :env (:env beta-node) - :msg "compiling negation with join filter node"}}) - prev) - :test (handle-expr prev - (compile-test id (:constraints condition) (:env beta-node)) - id - :test-expr - {:compile-ctx {:condition condition - :env (:env beta-node) - :msg "compiling test node"}}) - :accumulator (cond-> (handle-expr prev - (compile-accum id - (if (:join-filter-expressions beta-node) - "AccumulateWithJoinFilterNode" - "AccumulateNode") - (:accumulator beta-node) - (:env beta-node)) - id - :accum-expr - {:compile-ctx {:condition condition - :accumulator (:accumulator beta-node) - :env (:env beta-node) - :msg "compiling accumulator"}}) - - (:join-filter-expressions beta-node) - (handle-expr (compile-join-filter id - "AccumulateWithJoinFilterNode" - (:join-filter-expressions beta-node) - (:join-filter-join-bindings beta-node) - (:new-bindings beta-node) - (:env beta-node)) - id - :join-filter-expr - {:compile-ctx {:condition condition - :join-filter-expressions (:join-filter-expressions beta-node) - :env (:env beta-node) - :msg "compiling accumulate with join filter node"}})) - :query prev - - ;; This error should only be thrown if there are changes to the compilation of the beta-graph - ;; such as an addition of a node type. - (throw (ex-info "Invalid node type encountered while compiling rulebase." - {:node beta-node}))))) - id->expr - (:id-to-condition-node beta-graph)))) + (:id-to-production-node beta-graph)) + id->expr (reduce-kv + (fn add-conditions [prev id beta-node] + (let [condition (:condition beta-node) + condition (if (symbol? condition) + (clojure.lang.RT/classForName ^String (name condition)) + condition)] + (case (or (:node-type beta-node) + ;; If there is no :node-type then the node is the ::root-condition + ;; however, creating a case for nil could potentially cause weird effects if something about the + ;; compilation of the beta graph changes. Therefore making an explicit case for ::root-condition + ;; and if there was anything that wasn't ::root-condition this case statement will fail rather than + ;; failing somewhere else. + beta-node) + ::root-condition prev + + :join (if (or (root-node? backward-edges id) + (not (:join-filter-expressions beta-node))) + ;; This is either a RootJoin or HashJoin node, in either case they do not have an expression + ;; to capture. + prev + (handle-expr prev + (compile-join-filter id + "ExpressionJoinNode" + (:join-filter-expressions beta-node) + (:join-filter-join-bindings beta-node) + (:new-bindings beta-node) + (:env beta-node)) + id + :join-filter-expr + {:compile-ctx {:condition condition + :join-filter-expressions (:join-filter-expressions beta-node) + :env (:env beta-node) + :msg "compiling expression join node"}})) + :negation (if (:join-filter-expressions beta-node) + (handle-expr prev + (compile-join-filter id + "NegationWithJoinFilterNode" + (:join-filter-expressions beta-node) + (:join-filter-join-bindings beta-node) + (:new-bindings beta-node) + (:env beta-node)) + id + :join-filter-expr + {:compile-ctx {:condition condition + :join-filter-expressions (:join-filter-expressions beta-node) + :env (:env beta-node) + :msg "compiling negation with join filter node"}}) + prev) + :test (handle-expr prev + (compile-test id (:constraints condition) (:env beta-node)) + id + :test-expr + {:compile-ctx {:condition condition + :env (:env beta-node) + :msg "compiling test node"}}) + :accumulator (cond-> (handle-expr prev + (compile-accum id + (if (:join-filter-expressions beta-node) + "AccumulateWithJoinFilterNode" + "AccumulateNode") + (:accumulator beta-node) + (:env beta-node)) + id + :accum-expr + {:compile-ctx {:condition condition + :accumulator (:accumulator beta-node) + :env (:env beta-node) + :msg "compiling accumulator"}}) + + (:join-filter-expressions beta-node) + (handle-expr (compile-join-filter id + "AccumulateWithJoinFilterNode" + (:join-filter-expressions beta-node) + (:join-filter-join-bindings beta-node) + (:new-bindings beta-node) + (:env beta-node)) + id + :join-filter-expr + {:compile-ctx {:condition condition + :join-filter-expressions (:join-filter-expressions beta-node) + :env (:env beta-node) + :msg "compiling accumulate with join filter node"}})) + :query prev + + ;; This error should only be thrown if there are changes to the compilation of the beta-graph + ;; such as an addition of a node type. + (throw (ex-info "Invalid node type encountered while compiling rulebase." + {:node beta-node}))))) + id->expr + (:id-to-condition-node beta-graph))] + (persistent! id->expr))) + +(def forms-per-eval-default + "The default max number of forms that will be evaluated together as a single batch. + 5000 is chosen here due to the way that clojure will evaluate the vector of forms extracted from the nodes. + The limiting factor here is the max java method size (64KiB), clojure will compile each form in the vector down into + its own class file and generate another class file that will reference each of the other functions and wrap them in + a vector inside a static method. For example, + + (eval [(fn one [_] ...) (fn two [_] ...)]) + would generate 3 classes. + + some_namespace$eval1234 + some_namespace$eval1234$one_1234 + some_namespace$eval1234$two_1235 + + some_namespace$eval1234$one_1234 and some_namespace$eval1234$two_1235 contian the implementation of the functions, + where some_namespace$eval1234 will contain two methods, invoke and invokeStatic. + The invokeStatic method breaks down into something similar to a single create array call followed by 2 array set calls + with new invocations on the 2 classes the method then returns a new vector created from the array. + + 5000 is lower than the absolute max to allow for modifications to how clojure compiles without needing to modify this. + The current limit should be 5471, this is derived from the following opcode investigation: + + Array creation: 5B + Creating and populating the first 6 elements of the array: 60B + Creating and populating the next 122 elements of the array: 1,342B + Creating and populating the next 5343 elements of the array: 64,116B + Creating the vector and the return statement: 4B + + This sums to 65,527B just shy of the 65,536B method size limit." + 5000) (sc/defn compile-exprs :- schema/NodeFnLookup "Takes a map in the form produced by extract-exprs and evaluates the values(expressions) of the map in a batched manner. This allows the eval calls to be more effecient, rather than evaluating each expression on its own. See #381 for more details." [key->expr :- schema/NodeExprLookup - partition-size :- sc/Int] - (let [batching-try-eval (fn [compilation-ctxs exprs] + options :- {sc/Keyword sc/Any}] + (let [expr-cache (or (:compiler-cache options) + default-compiler-cache) + forms-per-eval (or (:forms-per-eval options) + forms-per-eval-default) + hash-expr-fn (or (:hash-expr-fn options) + hash) + prepare-expr (fn do-prepare-expr + [[expr-key [expr compilation-ctx]]] + (if expr-cache + (let [cache-key [(hash-expr-fn expr) + (hash-expr-fn compilation-ctx)] + compilation-ctx (assoc compilation-ctx :cache-key cache-key) + compiled-handler (some-> compilation-ctx :compile-ctx :production :handler resolve) + compiled-expr (or compiled-handler + (cache/lookup expr-cache cache-key))] + (if compiled-expr + [:compiled [expr-key [compiled-expr compilation-ctx]]] + [:prepared [expr-key [expr compilation-ctx]]])) + [:prepared [expr-key [expr compilation-ctx]]])) + batching-try-eval (fn do-compile-exprs + [exprs compilation-ctxs] ;; Try to evaluate all of the expressions as a batch. If they fail the batch eval then we ;; try them one by one with their compilation context, this is slow but we were going to fail ;; anyway. (try - (mapv vector (eval exprs) compilation-ctxs) + (mapv + (fn do-cache-expr + [compiled-expr compilation-ctx] + (when-let [cache-key (:cache-key compilation-ctx)] + (cache/miss expr-cache cache-key compiled-expr)) + [compiled-expr compilation-ctx]) + (eval exprs) compilation-ctxs) (catch Exception e ;; Using mapv here rather than map to avoid laziness, otherwise compilation failure might ;; fall into the throw below for the wrong reason. @@ -1510,24 +1593,28 @@ "that the method size exceeded the maximum set by the jvm, see the cause for the actual error.") {:compilation-ctxs compilation-ctxs} e)))))] - (into {} + (into (hf/hash-map) cat ;; Grouping by ns, most expressions will not have a defined ns, only expressions from production nodes. ;; These expressions must be evaluated in the ns where they were defined, as they will likely contain code ;; that is namespace dependent. - (for [[nspace group] (sort-by key (group-by (comp :ns second val) key->expr)) + (for [[nspace ns-expr-group] (sort-by key (group-by (comp :ns second val) key->expr)) ;; Partitioning the number of forms to be evaluated, Java has a limit to the size of methods if we were ;; evaluate all expressions at once it would likely exceed this limit and throw an exception. - expr-batch (partition-all partition-size group) - :let [node-expr-keys (mapv first expr-batch) - compilation-ctxs (mapv (comp second val) expr-batch) - exprs (mapv (comp first val) expr-batch)]] - (mapv vector - node-expr-keys - (with-bindings (if nspace - {#'*ns* (the-ns nspace)} - {}) - (batching-try-eval compilation-ctxs exprs))))))) + expr-batch (partition-all forms-per-eval ns-expr-group) ;;;; [ [ ]] + :let [grouped-exprs (->> (mapv prepare-expr expr-batch) + (group-by first)) + prepared-exprs (map second (:prepared grouped-exprs)) + node-expr-keys (mapv first prepared-exprs) + exprs (mapv (comp first second) prepared-exprs) + compilation-ctxs (mapv (comp second second) prepared-exprs) + prev-compiled-exprs (map second (:compiled grouped-exprs)) + next-compiled-exprs (mapv vector node-expr-keys + (with-bindings (if nspace + {#'*ns* (the-ns nspace)} + {}) + (batching-try-eval exprs compilation-ctxs)))]] + (concat prev-compiled-exprs next-compiled-exprs))))) (defn safe-get "A helper function for retrieving a given key from the provided map. If the key doesn't exist within the map this @@ -1541,18 +1628,19 @@ (sc/defn ^:private compile-node "Compiles a given node description into a node usable in the network with the - given children." - [beta-node :- (sc/either schema/ConditionNode schema/ProductionNode) + given children." + [beta-node :- (sc/conditional + (comp #{:production :query} :node-type) schema/ProductionNode + :else schema/ConditionNode) id :- sc/Int is-root :- sc/Bool children :- [sc/Any] expr-fn-lookup :- schema/NodeFnLookup new-bindings :- #{sc/Keyword}] - (let [{:keys [condition production query join-bindings env]} beta-node condition (if (symbol? condition) - (.loadClass (clojure.lang.RT/makeClassLoader) (name condition)) + (clojure.lang.RT/classForName ^String (name condition)) condition) compiled-expr-fn (fn [id field] (first (safe-get expr-fn-lookup [id field])))] @@ -1563,25 +1651,25 @@ ;; Use an specialized root node for efficiency in this case. (if is-root (eng/->RootJoinNode - id - condition - children - join-bindings) + id + condition + children + join-bindings) ;; If the join operation includes arbitrary expressions ;; that can't expressed as a hash join, we must use the expressions (if (:join-filter-expressions beta-node) (eng/->ExpressionJoinNode - id - condition - (compiled-expr-fn id :join-filter-expr) - children - join-bindings) + id + condition + (compiled-expr-fn id :join-filter-expr) + children + join-bindings) (eng/->HashJoinNode - id - condition - children - join-bindings))) + id + condition + children + join-bindings))) :negation ;; Check to see if the negation includes an @@ -1589,24 +1677,24 @@ ;; and use the appropriate node type. (if (:join-filter-expressions beta-node) (eng/->NegationWithJoinFilterNode - id - condition - (compiled-expr-fn id :join-filter-expr) - children - join-bindings) + id + condition + (compiled-expr-fn id :join-filter-expr) + children + join-bindings) (eng/->NegationNode - id - condition - children - join-bindings)) + id + condition + children + join-bindings)) :test (eng/->TestNode - id - env - (:constraints condition) - (compiled-expr-fn id :test-expr) - children) + id + env + (:constraints condition) + (compiled-expr-fn id :test-expr) + children) :accumulator ;; We create an accumulator that accepts the environment for the beta node @@ -1623,46 +1711,46 @@ (if (:join-filter-expressions beta-node) (eng/->AccumulateWithJoinFilterNode - id - ;; Create an accumulator structure for use when examining the node or the tokens - ;; it produces. - {:accumulator (:accumulator beta-node) - ;; Include the original filter expressions in the constraints for inspection tooling. - :from (update-in condition [:constraints] - into (-> beta-node :join-filter-expressions :constraints))} - compiled-accum - (compiled-expr-fn id :join-filter-expr) - (:result-binding beta-node) - children - join-bindings - (:new-bindings beta-node)) + id + ;; Create an accumulator structure for use when examining the node or the tokens + ;; it produces. + {:accumulator (:accumulator beta-node) + ;; Include the original filter expressions in the constraints for inspection tooling. + :from (update-in condition [:constraints] + into (-> beta-node :join-filter-expressions :constraints))} + compiled-accum + (compiled-expr-fn id :join-filter-expr) + (:result-binding beta-node) + children + join-bindings + (:new-bindings beta-node)) ;; All unification is based on equality, so just use the simple accumulate node. (eng/->AccumulateNode - id - ;; Create an accumulator structure for use when examining the node or the tokens - ;; it produces. - {:accumulator (:accumulator beta-node) - :from condition} - compiled-accum - (:result-binding beta-node) - children - join-bindings - (:new-bindings beta-node)))) + id + ;; Create an accumulator structure for use when examining the node or the tokens + ;; it produces. + {:accumulator (:accumulator beta-node) + :from condition} + compiled-accum + (:result-binding beta-node) + children + join-bindings + (:new-bindings beta-node)))) :production (eng/->ProductionNode - id - production - (compiled-expr-fn id :action-expr)) + id + production + (compiled-expr-fn id :action-expr)) :query (eng/->QueryNode - id - query - (:params query))))) + id + query + (:params query))))) -(sc/defn ^:private compile-beta-graph :- {sc/Int sc/Any} +(sc/defn ^:private compile-beta-graph :- schema/MutableLongHashMap "Compile the beta description to the nodes used at runtime." [{:keys [id-to-production-node id-to-condition-node id-to-new-bindings forward-edges backward-edges]} :- schema/BetaGraph expr-fn-lookup :- schema/NodeFnLookup] @@ -1684,48 +1772,47 @@ (recur (set/difference pending-ids newly-satisfied-ids) updated-edges - (concat sorted-nodes newly-satisfied-ids)))))] - - (reduce (fn [id-to-compiled-nodes id-to-compile] - - ;; Get the condition or production node to compile - (let [node-to-compile (get id-to-condition-node - id-to-compile - (get id-to-production-node id-to-compile)) - - ;; Get the children. The children should be sorted because the - ;; id-to-compiled-nodes map is sorted. - children (->> (get forward-edges id-to-compile) - (select-keys id-to-compiled-nodes) - (vals))] - - ;; Sanity check for our logic... - (assert (= (count children) - (count (get forward-edges id-to-compile))) - "Each child should be compiled.") - - (if (= ::root-condition node-to-compile) - id-to-compiled-nodes - (assoc id-to-compiled-nodes - id-to-compile - (compile-node node-to-compile - id-to-compile - (root-node? backward-edges id-to-compile) - children - expr-fn-lookup - (get id-to-new-bindings id-to-compile)))))) - ;; The node IDs have been determined before now, so we just need to sort the map returned. - ;; This matters because the engine will left-activate the beta roots with the empty token - ;; in the order that this map is seq'ed over. - (sorted-map) - ids-to-compile))) - + (concat sorted-nodes newly-satisfied-ids))))) + id-to-compiled-node + (reduce (fn [id-to-compiled-nodes id-to-compile] + + ;; Get the condition or production node to compile + (let [node-to-compile (get id-to-condition-node + id-to-compile + (get id-to-production-node id-to-compile)) + + ;; Get the children. The children should be sorted because the + ;; id-to-compiled-nodes map is sorted. + children (->> (get forward-edges id-to-compile) + (select-keys id-to-compiled-nodes) + (vals))] + + ;; Sanity check for our logic... + (assert (= (count children) + (count (get forward-edges id-to-compile))) + "Each child should be compiled.") + + (when (not= ::root-condition node-to-compile) + (hf/assoc! id-to-compiled-nodes + id-to-compile + (compile-node node-to-compile + id-to-compile + (root-node? backward-edges id-to-compile) + children + expr-fn-lookup + (get id-to-new-bindings id-to-compile)))) + id-to-compiled-nodes)) + ;; The node IDs have been determined before now, so we just need to sort the map returned. + ;; This matters because the engine will left-activate the beta roots with the empty token + ;; in the order that this map is seq'ed over. + (hf/mut-long-map) + ids-to-compile)] + id-to-compiled-node)) (sc/defn to-alpha-graph :- [schema/AlphaNode] "Returns a sequence of [condition-fn, [node-ids]] tuples to represent the alpha side of the network." [beta-graph :- schema/BetaGraph create-id-fn :- IFn] - ;; Create a sequence of tuples of conditions + env to beta node ids. (let [condition-to-node-ids (for [[id node] (:id-to-condition-node beta-graph) :when (:condition node)] @@ -1737,64 +1824,62 @@ ;; Can't use simple update-in because we need to ensure ;; the value is a vector, not a list. - (if (get node-map [condition env]) - (update-in node-map [[condition env]] conj node-id) - (assoc node-map [condition env] [node-id]))) - {} + (hm/compute! node-map [condition env] + (fn update-condition-to-node + [_ node-ids] + (if node-ids + (conj node-ids node-id) + [node-id]))) + node-map) + (hf/mut-map) condition-to-node-ids) ;; We sort the alpha nodes by the ordered sequence of the node ids they correspond to ;; in order to make the order of alpha nodes for any given type consistent. Note that we ;; coerce to a vector because we need a type that is comparable. - condition-to-node-entries (sort-by (fn [[k v]] (-> v sort vec)) + condition-to-node-entries (sort-by (fn [[_k v]] (-> v sort vec)) condition-to-node-map)] ;; Compile conditions into functions. (vec (for [[[condition env] node-ids] condition-to-node-entries - :when (:type condition) ; Exclude test conditions. - ] + :when (:type condition)] ; Exclude test conditions. (cond-> {:id (create-id-fn) :condition condition :beta-children (distinct node-ids)} (seq env) (assoc :env env)))))) - (sc/defn compile-alpha-nodes :- [{:id sc/Int :type sc/Any - :alpha-fn sc/Any ;; TODO: is a function... + :alpha-fn schema/Function (sc/optional-key :env) {sc/Keyword sc/Any} :children [sc/Num]}] [alpha-nodes :- [schema/AlphaNode] expr-fn-lookup :- schema/NodeFnLookup] - (for [{:keys [id condition beta-children env] :as node} alpha-nodes] - (cond-> {:id id - :type (effective-type (:type condition)) - :alpha-fn (first (safe-get expr-fn-lookup [id :alpha-expr])) - :children beta-children} - env (assoc :env env)))) + (vec + (for [{:keys [id condition beta-children env] :as node} alpha-nodes] + (cond-> {:id id + :type (effective-type (:type condition)) + :alpha-fn (first (safe-get expr-fn-lookup [id :alpha-expr])) + :children beta-children} + env (assoc :env env))))) ;; Wrap the fact-type so that Clojure equality and hashcode semantics are used ;; even though this is placed in a Java map. -(deftype AlphaRootsWrapper [fact-type ^int fact-type-hash roots] +(deftype AlphaRootsWrapper [^JavaEqualityWrapper fact-type wrapped] Object (equals [this other] (let [other ^AlphaRootsWrapper other] - (cond - - (identical? fact-type (.fact-type other)) - true - - (not (== fact-type-hash (.fact-type-hash other))) - false - - :else - (= fact-type (.fact-type other))))) + (.equals fact-type (.fact_type other)))) ;; Since know we will need to find the hashcode of this object in all cases just eagerly calculate it upfront ;; and avoid extra calls to hash later. - (hashCode [this] fact-type-hash)) + (hashCode [this] (.hash_code fact-type))) + +(defn alpha-roots-wrap + [fact-type roots] + (AlphaRootsWrapper. (jeq-wrap fact-type) roots)) (defn- create-get-alphas-fn "Returns a function that given a sequence of facts, @@ -1821,7 +1906,7 @@ ;; Exclude system types from having ancestors for now ;; since none of our use-cases require them. If this changes ;; we may need to define a custom hierarchy for them. - #{} + (hs/set) (ancestors-fn fact-type))) fact-type->roots (memoize @@ -1836,26 +1921,27 @@ ;; removing groups with no alpha nodes here will improve performance on subsequent calls ;; to the get-alphas-fn with the same fact type. (keep #(when-let [roots (not-empty (get alpha-roots %))] - (AlphaRootsWrapper. % (hash %) roots))) + (alpha-roots-wrap % roots))) ;; If a user-provided ancestors-fn returns a sorted collection, for example for ;; ensuring determinism, we respect that ordering here by conj'ing on to the existing ;; collection. (conj (wrapped-ancestors-fn fact-type) fact-type)))) update-roots->facts! (fn [^java.util.Map roots->facts roots-group fact] - (if-let [v (.get roots->facts roots-group)] - (.add ^java.util.List v fact) - (.put roots->facts roots-group (doto (java.util.LinkedList.) - (.add fact)))))] + (hm/compute! roots->facts roots-group + (fn update-roots + [_ facts] + (let [^java.util.List fact-list (or facts (hf/mut-list))] + (.add fact-list fact) + fact-list))))] (fn [facts] (let [roots->facts (java.util.LinkedHashMap.)] - (doseq [fact facts roots-group (fact-type->roots (wrapped-fact-type-fn fact))] (update-roots->facts! roots->facts roots-group fact)) - (let [return-list (java.util.LinkedList.) + (let [return-list (hf/mut-list) entries (.entrySet roots->facts) entries-it (.iterator entries)] ;; We iterate over the LinkedHashMap manually to avoid potential issues described at http://dev.clojure.org/jira/browse/CLJ-1738 @@ -1867,16 +1953,23 @@ (loop [] (when (.hasNext entries-it) (let [^java.util.Map$Entry e (.next entries-it)] - (.add return-list [(-> e ^AlphaRootsWrapper (.getKey) .roots) - (java.util.Collections/unmodifiableList (.getValue e))]) + (.add return-list [(-> e ^AlphaRootsWrapper (.getKey) (.wrapped)) + (hf/persistent! (.getValue e))]) (recur)))) + (hf/persistent! return-list)))))) - (java.util.Collections/unmodifiableList return-list)))))) - +(defn create-ancestors-fn + [{:keys [ancestors-fn + hierarchy]}] + (let [hierarchy-fn (when hierarchy + (partial ancestors hierarchy))] + (if (and ancestors-fn hierarchy-fn) + (comp (partial apply set/union) (juxt ancestors-fn hierarchy-fn)) + (or ancestors-fn hierarchy-fn ancestors)))) (sc/defn build-network "Constructs the network from compiled beta tree and condition functions." - [id-to-node :- {sc/Int sc/Any} + [id-to-node :- schema/MutableLongHashMap beta-roots alpha-fns productions @@ -1885,7 +1978,6 @@ activation-group-sort-fn activation-group-fn expr-fn-lookup] - (let [beta-nodes (vals id-to-node) production-nodes (for [node beta-nodes @@ -1896,55 +1988,39 @@ :when (= QueryNode (type node))] node) - query-map (into {} (for [query-node query-nodes - - ;; Queries can be looked up by reference or by name; - entry [[(:query query-node) query-node] - [(:name (:query query-node)) query-node]]] - entry)) - - ;; type, alpha node tuples. - alpha-nodes (for [{:keys [id type alpha-fn children env] :as alpha-map} alpha-fns - :let [beta-children (map id-to-node children)]] - [type (eng/->AlphaNode id env beta-children alpha-fn type)]) - - ;; Merge the alpha nodes into a multi-map - alpha-map (reduce - (fn [alpha-map [type alpha-node]] - (update-in alpha-map [type] conj alpha-node)) - {} - alpha-nodes) - - ;; Merge the alpha nodes into the id-to-node map - id-to-node (into id-to-node - (map (juxt :id identity)) - (mapv second alpha-nodes)) - - get-alphas-fn (create-get-alphas-fn fact-type-fn ancestors-fn alpha-map)] - - #_{:clj-kondo/ignore [:unresolved-symbol]} - (strict-map->Rulebase - {:alpha-roots alpha-map - :beta-roots beta-roots - :productions productions - :production-nodes production-nodes - :query-nodes query-map - :id-to-node id-to-node - :activation-group-sort-fn activation-group-sort-fn - :activation-group-fn activation-group-fn - :get-alphas-fn get-alphas-fn - :node-expr-fn-lookup expr-fn-lookup}))) - -;; Cache of sessions for fast reloading. -(def ^:private session-cache (atom {})) - -(defn clear-session-cache! - "Clears the cache of reusable Clara sessions, so any subsequent sessions - will be re-compiled from the rule definitions. This is intended for use - by tooling or specialized needs; most users can simply specify the :cache false - option when creating sessions." - [] - (reset! session-cache {})) + query-map (->> (for [query-node query-nodes + + ;; Queries can be looked up by reference or by name; + entry [[(:query query-node) query-node] + [(:name (:query query-node)) query-node]]] + entry) + (into (hf/hash-map))) + alpha-map (hf/mut-map)] + ;; Merge the alpha nodes into a multi-map + (doseq [{:keys [id type alpha-fn children env]} alpha-fns + :let [beta-children (map id-to-node children) + alpha-node (eng/->AlphaNode id env beta-children alpha-fn type)]] + (hf/assoc! id-to-node (:id alpha-node) alpha-node) + (hm/compute! alpha-map type + (fn add-alpha + [_ alpha-nodes] + (if alpha-nodes + (conj alpha-nodes alpha-node) + (list alpha-node)))) + [type alpha-node]) + (let [get-alphas-fn (create-get-alphas-fn fact-type-fn ancestors-fn alpha-map)] + #_{:clj-kondo/ignore [:unresolved-symbol]} + (strict-map->Rulebase + {:alpha-roots (hf/persistent! alpha-map) + :beta-roots beta-roots + :productions productions + :production-nodes production-nodes + :query-nodes query-map + :id-to-node (hf/persistent! id-to-node) + :activation-group-sort-fn activation-group-sort-fn + :activation-group-fn activation-group-fn + :get-alphas-fn get-alphas-fn + :node-expr-fn-lookup expr-fn-lookup})))) (defn production-load-order-comp [a b] (< (-> a meta ::rule-load-order) @@ -1963,37 +2039,6 @@ productions (throw (ex-info (str "Non-unique production names: " non-unique) {:names non-unique}))))) -(def forms-per-eval-default - "The default max number of forms that will be evaluated together as a single batch. - 5000 is chosen here due to the way that clojure will evaluate the vector of forms extracted from the nodes. - The limiting factor here is the max java method size (64KiB), clojure will compile each form in the vector down into - its own class file and generate another class file that will reference each of the other functions and wrap them in - a vector inside a static method. For example, - - (eval [(fn one [_] ...) (fn two [_] ...)]) - would generate 3 classes. - - some_namespace$eval1234 - some_namespace$eval1234$one_1234 - some_namespace$eval1234$two_1235 - - some_namespace$eval1234$one_1234 and some_namespace$eval1234$two_1235 contian the implementation of the functions, - where some_namespace$eval1234 will contain two methods, invoke and invokeStatic. - The invokeStatic method breaks down into something similar to a single create array call followed by 2 array set calls - with new invocations on the 2 classes the method then returns a new vector created from the array. - - 5000 is lower than the absolute max to allow for modifications to how clojure compiles without needing to modify this. - The current limit should be 5471, this is derived from the following opcode investigation: - - Array creation: 5B - Creating and populating the first 6 elements of the array: 60B - Creating and populating the next 122 elements of the array: 1,342B - Creating and populating the next 5343 elements of the array: 64,116B - Creating the vector and the return statement: 4B - - This sums to 65,527B just shy of the 65,536B method size limit." - 5000) - (def omit-compile-ctx-default "During construction of the Session there is data maintained such that if the underlying expressions fail to compile then this data can be used to explain the failure and the constraints of the rule who's expression is being evaluated. @@ -2007,33 +2052,17 @@ "Compile the rules into a rete network and return the given session." [productions :- #{schema/Production} options :- {sc/Keyword sc/Any}] - (let [;; We need to put the productions in a sorted set here, instead of in mk-session, since we don't want - ;; a sorted set in the session-cache. If we did only rule order would be used to compare set equality - ;; for finding a cache hit, and we want to use the entire production, which a non-sorted set does. - ;; When using a sorted set, for constant options, - ;; any session creation with n productions would be a cache hit if any previous session had n productions. - ;; Furthermore, we can avoid the work of sorting the set until we know that there was a cache miss. - ;; - ;; Note that this ordering is not for correctness; we are just trying to increase consistency of rulebase compilation, - ;; and hopefully thereby execution times, from run to run. - _ (validate-names-unique productions) - productions (with-meta (into (sorted-set-by production-load-order-comp) - productions) - ;; Store the name of the custom comparator for durability. - {:clara.rules.durability/comparator-name `production-load-order-comp}) - - ;; A stateful counter used for unique ids of the nodes of the graph. + (validate-names-unique productions) + (let [;; A stateful counter used for unique ids of the nodes of the graph. id-counter (atom 0) create-id-fn (fn [] (swap! id-counter inc)) - forms-per-eval (:forms-per-eval options forms-per-eval-default) - beta-graph (to-beta-graph productions create-id-fn) alpha-graph (to-alpha-graph beta-graph create-id-fn) ;; Extract the expressions from the graphs and evaluate them in a batch manner. ;; This is a performance optimization, see Issue 381 for more information. - exprs (compile-exprs (extract-exprs beta-graph alpha-graph) forms-per-eval) + exprs (compile-exprs (extract-exprs beta-graph alpha-graph) options) ;; If we have made it to this point, it means that we have succeeded in compiling all expressions ;; thus we can free the :compile-ctx used for troubleshooting compilation failures. @@ -2042,10 +2071,10 @@ ;; in diagnosing compilation errors in specific rules. omit-compile-ctx (:omit-compile-ctx options omit-compile-ctx-default) exprs (if omit-compile-ctx - (into {} + (into (hf/hash-map) (map - (fn [[k [expr ctx]]] - [k [expr (dissoc ctx :compile-ctx)]])) + (fn [[k [expr ctx]]] + [k [expr (dissoc ctx :compile-ctx)]])) exprs) exprs) @@ -2059,8 +2088,7 @@ type) ;; The ancestors for a logical type uses Clojure's ancestors function unless overridden. - ancestors-fn (or (get options :ancestors-fn) - ancestors) + ancestors-fn (create-ancestors-fn options) ;; The default is to sort activations in descending order by their salience. activation-group-sort-fn (eng/options->activation-group-sort-fn options) @@ -2075,13 +2103,14 @@ get-alphas-fn (:get-alphas-fn rulebase) - transport (LocalTransport.)] + transport (LocalTransport.) - (eng/assemble {:rulebase rulebase - :memory (eng/local-memory rulebase transport activation-group-sort-fn activation-group-fn get-alphas-fn) - :transport transport - :listeners (get options :listeners []) - :get-alphas-fn get-alphas-fn}))) + session (eng/assemble {:rulebase rulebase + :memory (eng/local-memory rulebase transport activation-group-sort-fn activation-group-fn get-alphas-fn) + :transport transport + :listeners (get options :listeners []) + :get-alphas-fn get-alphas-fn})] + session)) (defn add-production-load-order "Adds ::rule-load-order to metadata of productions. Custom DSL's may need to use this if @@ -2091,37 +2120,82 @@ (vary-meta production assoc ::rule-load-order (or n 0))) (range) productions)) +(defn- classify-load-type + [source] + (cond + (:lhs source) + :productions + + (and (:parents source) + (:ancestors source) + (:descendants source)) + :hierarchies + + :else nil)) + +(defn load-source* + "loads the rules, queries and hierarchies from a source if it implements `IClaraSOurce`, or navigates inside + collections to recursively load from vectors, lists, sets, seqs." + [source] + (cond + (u/instance-satisfies? IClaraSource source) + (load-source source) + + (or (vector? source) + (list? source) + (set? source) + (seq? source)) + (mapcat load-source* source) + + (var? source) + (load-source* @source) + + (classify-load-type source) + [source] + + :else [])) + (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." ([sources-and-options] (let [sources (take-while (complement keyword?) sources-and-options) options (apply hash-map (drop-while (complement keyword?) sources-and-options)) - productions (->> sources - ;; Load rules from the source, or just use the input as a seq. - (mapcat #(if (satisfies? IRuleSource %) - (load-rules %) - %)) - add-production-load-order - ;; Ensure that we choose the earliest occurrence of a rule for the purpose of rule order. - ;; There are Clojure core functions for distinctness, of course, but none of them seem to guarantee - ;; which instance will be chosen in case of duplicates. - (reduce (fn [previous new-production] - ;; Contains? is broken for transient sets; see http://dev.clojure.org/jira/browse/CLJ-700 - ;; Since all values in this set should be truthy, we can just use the set as a function instead. - (if (previous new-production) - previous - (conj! previous new-production))) - (transient #{})) - persistent!)] - - (if-let [session (get @session-cache [productions options])] - session - (let [session (mk-session* productions options)] - - ;; Cache the session unless instructed not to. - (when (get options :cache true) - (swap! session-cache assoc [productions options] session)) - - ;; Return the session. - session))))) + {:keys [productions + hierarchies]} (->> (mapcat load-source* sources) + (group-by classify-load-type)) + productions-loaded (add-production-load-order productions) + productions-unique (hs/set productions-loaded) + productions-sorted (with-meta + (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->> hierarchies + options-hierarchy + (cons (:hierarchy options))) + hierarchy (when (seq 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)) + options-cache (get options :cache) + session-cache (cond + (true? options-cache) + default-session-cache + (nil? options-cache) + default-session-cache + :else options-cache) + hash-expr-fn (or (:hash-expr-fn options) hash) + ;;; this is simpler than storing all the productions and options in the cache + session-key [(hash-expr-fn productions-sorted) + (hash-expr-fn (dissoc options :cache :compiler-cache))]] + (if session-cache + (cache/lookup-or-miss session-cache session-key + (fn do-mk-session [_] + (mk-session* productions-sorted options))) + (mk-session* productions-sorted options))))) diff --git a/src/main/clojure/clara/rules/dsl.clj b/src/main/clojure/clara/rules/dsl.clj index 0f1aeec0..8fb13361 100644 --- a/src/main/clojure/clara/rules/dsl.clj +++ b/src/main/clojure/clara/rules/dsl.clj @@ -1,15 +1,8 @@ (ns clara.rules.dsl "Implementation of the defrule-style DSL for Clara. Most users should simply use the clara.rules namespace." - (:require [clojure.reflect :as reflect] - [clojure.core.reducers :as r] - [clojure.set :as s] - [clojure.string :as string] - [clojure.walk :as walk] - [clara.rules.engine :as eng] + (:require [clojure.walk :as walk] [clara.rules.compiler :as com] - [clara.rules.platform :as platform] - [clara.rules.schema :as schema] - [schema.core :as sc]) + [clara.rules.platform :as platform]) (:refer-clojure :exclude [qualified-keyword?])) ;; Let operators be symbols or keywords. @@ -20,13 +13,15 @@ [x] (and (symbol? x) (= "=>" (name x)))) (defn split-lhs-rhs - "Given a rule with the =>, splits the left- and right-hand sides." - [rule-body] - (let [[lhs [sep & rhs]] (split-with #(not (separator? %)) rule-body)] - - {:lhs lhs - :rhs (when-not (empty? rhs) - (conj rhs 'do))})) + "Given a rule with the =>, splits the left- and right-hand sides." + [rule-body] + (let [[pre [sep & post]] (split-with (complement separator?) rule-body) + [lhs rhs] (if sep + [pre post] + ['() pre])] + {:lhs lhs + :rhs (when-not (empty? rhs) + (conj rhs 'do))})) (defn- throw-dsl-ex "Throws an exception indicating a failure parsing a form." @@ -49,12 +44,7 @@ "Creates a condition with the given optional result binding when parsing a rule." [condition result-binding expr-meta] (let [type (if (symbol? (first condition)) - (if-let [resolved (and - ;; If we are compiling ClojureScript rules we don't want - ;; to resolve the symbol in the ClojureScript compiler's - ;; Clojure environment. See issue 300. - (not (com/compiling-cljs?)) - (resolve (first condition)))] + (if-let [resolved (resolve (first condition))] ;; If the type resolves to a var, grab its contents for the match. (if (var? resolved) @@ -95,12 +85,12 @@ (with-meta (cond-> {:type type :constraints constraints} - args (assoc :args args) - result-binding (assoc :fact-binding result-binding)) + args (assoc :args args) + result-binding (assoc :fact-binding result-binding)) (if (seq constraints) (assoc (meta (first constraints)) - :file *file*))))) + :file *file*))))) (defn- parse-condition-or-accum "Parse an expression that could be a condition or an accumulator." @@ -131,80 +121,69 @@ [expression expr-meta] (cond - (contains? ops (first expression)) - (into [(keyword (name (first expression)))] ; Ensure expression operator is a keyword. - (for [nested-expr (rest expression)] - (parse-expression nested-expr expr-meta))) - - (contains? #{'test :test} (first expression)) - (if (= 1 (count expression)) - (throw-dsl-ex (str "Empty :test conditions are not allowed.") - {} - expr-meta) - {:constraints (vec (rest expression))}) + (contains? ops (first expression)) + (into [(keyword (name (first expression)))] ; Ensure expression operator is a keyword. + (for [nested-expr (rest expression)] + (parse-expression nested-expr expr-meta))) + (contains? #{'test :test} (first expression)) + (if (= 1 (count expression)) + (throw-dsl-ex (str "Empty :test conditions are not allowed.") + {} + expr-meta) + {:constraints (vec (rest expression))}) - :default - (parse-condition-or-accum expression expr-meta))) + :else + (parse-condition-or-accum expression expr-meta))) (defn- maybe-qualify "Attempt to qualify the given symbol, returning the symbol itself if we can't qualify it for any reason." [env sym] (let [env (set env)] - (if (com/compiling-cljs?) - - ;; Qualify the symbol using the CLJS analyzer. - (if-let [resolved (and (symbol? sym) - (not (env sym)) - (com/resolve-cljs-sym (com/cljs-ns) sym))] - resolved - sym) - - (if (and (symbol? sym) - (not= '.. sym) ; Skip the special .. host interop macro. - (.endsWith (name sym) ".")) - - ;; The . suffix indicates a type constructor, so we qualify the type instead, then - ;; re-add the . to the resolved type. - (-> (subs (name sym) - 0 - (dec (count (name sym)))) ; Get the name without the trailing dot. - (symbol) ; Convert it back to a symbol. - ^Class (resolve) ; Resolve into the type class. - (.getName) ; Get the qualified name. - (str ".") ; Re-add the dot for the constructor, which is now qualified - (symbol)) ; Convert back into a symbol used at compile time. - - ;; Qualify a normal clojure symbol. - (if (and (symbol? sym) ; Only qualify symbols... - (not (env sym))) ; not in env (env contains locals).) ; that we can resolve - - (cond - ;; If it's a Java class, simply qualify it. - (instance? Class (resolve sym)) - (symbol (.getName ^Class (resolve sym))) - - ;; Don't qualify clojure.core for portability, since CLJS uses a different namespace. - (and (resolve sym) - (not (= "clojure.core" - (str (ns-name (:ns (meta (resolve sym))))))) - (name sym)) - (symbol (str (ns-name (:ns (meta (resolve sym))))) (name sym)) - - ;; See if it's a static method call and qualify it. - (and (namespace sym) - (not (resolve sym)) - (instance? Class (resolve (symbol (namespace sym))))) ; The namespace portion is the class name we try to resolve. - (symbol (.getName ^Class (resolve (symbol (namespace sym)))) - (name sym)) - - ;; Finally, just return the symbol unchanged if it doesn't match anything above, - ;; assuming it's a local parameter or variable.n - :default - sym) - - sym))))) + (if (and (symbol? sym) + (not= '.. sym) ; Skip the special .. host interop macro. + (.endsWith (name sym) ".")) + + ;; The . suffix indicates a type constructor, so we qualify the type instead, then + ;; re-add the . to the resolved type. + (-> (subs (name sym) + 0 + (dec (count (name sym)))) ; Get the name without the trailing dot. + (symbol) ; Convert it back to a symbol. + ^Class (resolve) ; Resolve into the type class. + (.getName) ; Get the qualified name. + (str ".") ; Re-add the dot for the constructor, which is now qualified + (symbol)) ; Convert back into a symbol used at compile time. + + ;; Qualify a normal clojure symbol. + (if (and (symbol? sym) ; Only qualify symbols... + (not (env sym))) ; not in env (env contains locals).) ; that we can resolve + + (cond + ;; If it's a Java class, simply qualify it. + (instance? Class (resolve sym)) + (symbol (.getName ^Class (resolve sym))) + + ;; Don't qualify clojure.core for portability, since CLJS uses a different namespace. + (and (resolve sym) + (not (= "clojure.core" + (str (ns-name (:ns (meta (resolve sym))))))) + (name sym)) + (symbol (str (ns-name (:ns (meta (resolve sym))))) (name sym)) + + ;; See if it's a static method call and qualify it. + (and (namespace sym) + (not (resolve sym)) + (instance? Class (resolve (symbol (namespace sym))))) ; The namespace portion is the class name we try to resolve. + (symbol (.getName ^Class (resolve (symbol (namespace sym)))) + (name sym)) + + ;; Finally, just return the symbol unchanged if it doesn't match anything above, + ;; assuming it's a local parameter or variable.n + :else + sym) + sym)))) (defn- qualify-meta "Qualify metadata associated with the symbol." @@ -241,13 +220,11 @@ (defn parse-rule* "Creates a rule from the DSL syntax using the given environment map. *ns* should be bound to the namespace the rule is meant to be defined in." - ([lhs rhs properties env] - (parse-rule* lhs rhs properties env {})) - ([lhs rhs properties env rule-meta] + ([lhs rhs properties rule-env rule-meta] (let [conditions (into [] (for [expr lhs] (parse-expression expr rule-meta))) - rule {:ns-name (list 'quote (ns-name (if (com/compiling-cljs?) (com/cljs-ns) *ns*))) + rule {:ns-name (list 'quote (ns-name *ns*)) :lhs (list 'quote (mapv #(resolve-vars % (destructure-syms %)) conditions)) @@ -256,23 +233,46 @@ assoc :file *file*))} symbols (set (filter symbol? (com/flatten-expression (concat lhs rhs)))) - matching-env (into {} (for [sym (keys env) + matching-env (into {} (for [sym (keys rule-env) :when (symbols sym)] [(keyword (name sym)) sym]))] (cond-> rule ;; Add properties, if given. - (not (empty? properties)) (assoc :props properties) + (seq properties) (assoc :props properties) ;; Add the environment, if given. - (not (empty? env)) (assoc :env matching-env))))) + (seq rule-env) (assoc :env matching-env))))) + +(defn parse-rule-action* + "Creates a rule action from the DSL syntax using the given environment map. *ns* + should be bound to the namespace the rule is meant to be defined in." + ([lhs rhs properties rule-env rule-meta] + (let [conditions (into [] (for [expr lhs] + (parse-expression expr rule-meta))) + + rule {:ns-name (ns-name *ns*) + :lhs (mapv #(resolve-vars % (destructure-syms %)) + conditions) + :rhs (vary-meta rhs assoc :file *file*)} + + symbols (set (filter symbol? (com/flatten-expression (concat lhs rhs)))) + matching-env (into {} (for [sym (keys rule-env) + :when (symbols sym)] + [(keyword (name sym)) sym]))] + + (cond-> rule + + ;; Add properties, if given. + (seq properties) (assoc :props properties) + + ;; Add the environment, if given. + (seq rule-env) (assoc :env matching-env))))) (defn parse-query* "Creates a query from the DSL syntax using the given environment map." - ([params lhs env] - (parse-query* params lhs env {})) - ([params lhs env query-meta] + ([params lhs query-env query-meta] (let [conditions (into [] (for [expr lhs] (parse-expression expr query-meta))) @@ -282,19 +282,19 @@ symbols (set (filter symbol? (com/flatten-expression lhs))) matching-env (into {} - (for [sym (keys env) + (for [sym (keys query-env) :when (symbols sym)] [(keyword (name sym)) sym]))] (cond-> query - (not (empty? env)) (assoc :env matching-env))))) + (seq query-env) (assoc :env matching-env))))) (defmacro parse-rule "Macro used to dynamically create a new rule using the DSL syntax." ([lhs rhs] - (parse-rule* lhs rhs nil &env)) + (parse-rule* lhs rhs nil &env (meta &form))) ([lhs rhs properties] - (parse-rule* lhs rhs properties &env))) + (parse-rule* lhs rhs properties &env (meta &form)))) ;;; added to clojure.core in 1.9 (defn- qualified-keyword? @@ -305,19 +305,30 @@ [prod-name] (cond (qualified-keyword? prod-name) prod-name - (com/compiling-cljs?) (str (name (com/cljs-ns)) "/" (name prod-name)) :else (str (name (ns-name *ns*)) "/" (name prod-name)))) (defn build-rule "Function used to parse and build a rule using the DSL syntax." - ([name body] (build-rule name body {})) - ([name body form-meta] + ([name body rule-env rule-meta] + (let [doc (if (string? (first body)) (first body) nil) + body (if doc (rest body) body) + properties (if (map? (first body)) (first body) nil) + definition (if properties (rest body) body) + {:keys [lhs rhs]} (split-lhs-rhs definition)] + (cond-> (parse-rule* lhs rhs properties rule-env rule-meta) + + name (assoc :name (production-name name)) + doc (assoc :doc doc))))) + +(defn build-rule-action + "Function used to parse and build a rule action using the DSL syntax." + ([name body rule-env rule-meta] (let [doc (if (string? (first body)) (first body) nil) body (if doc (rest body) body) properties (if (map? (first body)) (first body) nil) definition (if properties (rest body) body) {:keys [lhs rhs]} (split-lhs-rhs definition)] - (cond-> (parse-rule* lhs rhs properties {} form-meta) + (cond-> (parse-rule-action* lhs rhs properties rule-env rule-meta) name (assoc :name (production-name name)) doc (assoc :doc doc))))) @@ -325,15 +336,14 @@ (defmacro parse-query "Macro used to dynamically create a new rule using the DSL syntax." [params lhs] - (parse-query* params lhs &env)) + (parse-query* params lhs &env (meta &form))) (defn build-query "Function used to parse and build a query using the DSL syntax." - ([name body] (build-query name body {})) - ([name body form-meta] + ([name body env form-meta] (let [doc (if (string? (first body)) (first body) nil) binding (if doc (second body) (first body)) definition (if doc (drop 2 body) (rest body))] - (cond-> (parse-query* binding definition {} form-meta) + (cond-> (parse-query* binding definition env form-meta) name (assoc :name (production-name name)) doc (assoc :doc doc))))) diff --git a/src/main/clojure/clara/rules/durability.clj b/src/main/clojure/clara/rules/durability.clj index 5d6e95b9..329a36df 100644 --- a/src/main/clojure/clara/rules/durability.clj +++ b/src/main/clojure/clara/rules/durability.clj @@ -12,16 +12,10 @@ (:require [clara.rules.engine :as eng] [clara.rules.compiler :as com] [clara.rules.memory :as mem] - [clojure.set :as set] [schema.core :as s]) - (:import [clara.rules.compiler - Rulebase] - [clara.rules.memory - RuleOrderedActivation] - [java.util - List - Map - IdentityHashMap])) + (:import [clara.rules.compiler Rulebase] + [clara.rules.memory RuleOrderedActivation] + [java.util List Map])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Rulebase serialization helpers. @@ -84,8 +78,8 @@ "Gets the numeric index for the given struct from the clj-struct-holder." [fact] (-> clj-struct-holder - ^Map (.get) - (.get fact))) + ^Map (.get) + (.get fact))) (defn clj-struct-holder-add-fact-idx! "Adds the fact to the clj-struct-holder with a new index. This can later be retrieved @@ -96,26 +90,26 @@ ;; at read-time. This could have a cast to long here, but it would waste time ;; unnecessarily. (-> clj-struct-holder - ^Map (.get) - (.put fact (-> clj-struct-holder - ^Map (.get) - (.size))))) + ^Map (.get) + (.put fact (-> clj-struct-holder + ^Map (.get) + (.size))))) (defn clj-struct-idx->obj "The reverse of clj-struct->idx. Returns an object for the given index found in clj-struct-holder." [id] (-> clj-struct-holder - ^List (.get) - (.get id))) + ^List (.get) + (.get id))) (defn clj-struct-holder-add-obj! "The reverse of clj-struct-holder-add-fact-idx!. Adds the object to the clj-struct-holder at the next available index." [fact] (-> clj-struct-holder - ^List (.get) - (.add fact)) + ^List (.get) + (.add fact)) fact) (defn create-map-entry @@ -252,13 +246,13 @@ (if-let [idx (find-mem-internal-idx internal-seen token)] idx (let [indexed (-> token - (update :matches - #(mapv (fn [[fact node-id]] - [(find-index-or-add! seen fact) - node-id]) - %)) - (update :bindings - #(index-bindings seen %)))] + (update :matches + #(mapv (fn [[fact node-id]] + [(find-index-or-add! seen fact) + node-id]) + %)) + (update :bindings + #(index-bindings seen %)))] (add-mem-internal-idx! internal-seen token indexed)))) (defn index-alpha-memory [internal-seen seen amem] @@ -268,10 +262,10 @@ (mapv #(if-let [idx (find-mem-internal-idx internal-seen %)] idx (let [indexed (-> % - (update :fact - index-update-fact-fn) - (update :bindings - index-update-bindings-fn))] + (update :fact + index-update-fact-fn) + (update :bindings + index-update-bindings-fn))] (add-mem-internal-idx! internal-seen % indexed))) elements))] (update-vals amem @@ -363,17 +357,17 @@ (defn find-mem-idx "Finds the fact from mem-facts at the given index. See docs on mem-facts for more." [idx] - (-> mem-facts - (.get) - (get idx))) + (-> mem-facts + (.get) + (get idx))) (defn find-internal-idx "Finds the fact from mem-internal at the given index. See docs on mem-internal for more." [idx] (-> mem-internal - (.get) - (get idx))) - + (.get) + (get idx))) + (defn indexed-session-memory-state "Takes the working memory from a session and strips it down to only the memory needed for serialization. Along with this, replaces all working memory facts with MemIdx place holders. @@ -472,7 +466,7 @@ (defn opts->get-alphas-fn [rulebase opts] (let [fact-type-fn (:fact-type-fn opts type) - ancestors-fn (:ancestors-fn opts ancestors)] + ancestors-fn (com/create-ancestors-fn opts)] (create-get-alphas-fn fact-type-fn ancestors-fn (:alpha-roots rulebase)))) @@ -490,7 +484,7 @@ of memory." ([rulebase opts] (let [{:keys [listeners transport]} opts] - + (eng/assemble {:rulebase rulebase :memory (eng/local-memory rulebase (clara.rules.engine.LocalTransport.) @@ -505,7 +499,7 @@ ([rulebase memory opts] (let [{:keys [listeners transport]} opts] - + (eng/assemble {:rulebase rulebase :memory (assoc memory :rulebase rulebase @@ -535,7 +529,7 @@ via the opts argument to both serialize and deserialize. Certain options are expected and required to be supported by any implementation of ISessionSerializer. These are referred to as the 'standard' options. - + These include: * :rulebase-only? - When true indicates the rulebase is the only part of the session to serializer. @@ -555,10 +549,15 @@ Larger batch sizes should see better performance compared to smaller batch sizes. Defaults to 5000, see clara.rules.compiler/forms-per-eval-default for more information. + * :compiler-cache, indicating wether the expression compilation can be cached, effectively memoizing eval expr, + valid values are true, false, or a wrapped CacheProtocol. + Options for the rulebase semantics that are documented at clara.rules/mk-session include: * :fact-type-fn + * :hash-expr-fn * :ancestors-fn + * :hierarchy * :activation-group-sort-fn * :activation-group-fn @@ -585,7 +584,7 @@ The important part of this serialization protocol is that the facts returned from deserialize-facts are in the *same order* as how they were given to serialize-facts." - + (serialize-facts [this fact-seq] "Serialize the given fact-seq, which is an order sequence of facts from working memory of a session. Note, as mentioned in the protocol docs, the *order* these are given is *important* and should be preserved @@ -614,7 +613,7 @@ be stored and retrieved a single time for potentially many sessions containing different working memory data, for the same rules. This function is only a convenience for passing the :rulebase-only? true flag to the serialize-session-state function. - See serialize-session-state for more." + See serialize-session-state for more." ([session :- (s/protocol eng/ISession) session-serializer :- (s/protocol ISessionSerializer)] (serialize-rulebase session @@ -696,7 +695,7 @@ (deserialize-session-state session-serializer memory-facts-serializer {})) - + ([session-serializer :- (s/protocol ISessionSerializer) memory-facts-serializer :- (s/protocol IWorkingMemorySerializer) opts :- {s/Any s/Any}] diff --git a/src/main/clojure/clara/rules/durability/fressian.clj b/src/main/clojure/clara/rules/durability/fressian.clj index 7f33673a..d39fdc5e 100644 --- a/src/main/clojure/clara/rules/durability/fressian.clj +++ b/src/main/clojure/clara/rules/durability/fressian.clj @@ -11,7 +11,9 @@ [schema.core :as s] [clojure.data.fressian :as fres] [clojure.java.io :as jio] - [clojure.main :as cm]) + [clojure.main :as cm] + [ham-fisted.api :as hf] + [ham-fisted.set :as hs]) (:import [clara.rules.durability MemIdx InternalMemIdx] @@ -47,7 +49,10 @@ WeakHashMap] [java.io InputStream - OutputStream])) + OutputStream] + [ham_fisted + IAPersistentSet + IAPersistentMap])) ;; Use this map to cache the symbol for the map->RecordNameHere ;; factory function created for every Clojure record to improve @@ -242,26 +247,51 @@ (read [_ rdr tag component-count] (resolve (.readObject rdr))))}} + "clojure.lang/var" + {:class clojure.lang.Var + :writer (reify WriteHandler + (write [_ w c] + (.writeTag w "clojure.lang/var" 1) + (.writeObject w (.toSymbol ^clojure.lang.Var c)))) + :readers {"clojure.lang/var" + (reify ReadHandler + (read [_ rdr tag component-count] + (resolve (.readObject rdr))))}} + + "hamf/set" + (create-identity-based-handler + IAPersistentSet + "hamf/set" + write-with-meta + (fn hamf-set-reader [rdr] (read-with-meta rdr hs/set))) + + "hamf/map" + (create-identity-based-handler + IAPersistentMap + "hamf/map" + (fn clj-map-writer [wtr tag m] (write-with-meta wtr tag m write-map)) + (fn clj-map-reader [rdr] (read-with-meta rdr (partial into (hf/hash-map))))) + "clj/set" (create-identity-based-handler - clojure.lang.APersistentSet - "clj/set" - write-with-meta - (fn clj-set-reader [rdr] (read-with-meta rdr set))) + clojure.lang.APersistentSet + "clj/set" + write-with-meta + (fn clj-set-reader [rdr] (read-with-meta rdr set))) "clj/vector" (create-identity-based-handler - clojure.lang.APersistentVector - "clj/vector" - write-with-meta - (fn clj-vec-reader [rdr] (read-with-meta rdr vec))) + clojure.lang.APersistentVector + "clj/vector" + write-with-meta + (fn clj-vec-reader [rdr] (read-with-meta rdr vec))) "clj/list" (create-identity-based-handler - clojure.lang.PersistentList - "clj/list" - write-with-meta - (fn clj-list-reader [rdr] (read-with-meta rdr #(apply list %)))) + clojure.lang.PersistentList + "clj/list" + write-with-meta + (fn clj-list-reader [rdr] (read-with-meta rdr #(apply list %)))) "clj/emptylist" ;; Not using the identity based handler as this will always be identical anyway @@ -280,115 +310,115 @@ (read [_ rdr tag component-count] (let [m (read-meta rdr)] (cond-> '() - m (with-meta m)))))}} + m (with-meta m)))))}} "clj/aseq" (create-identity-based-handler - clojure.lang.ASeq - "clj/aseq" - write-with-meta - (fn clj-seq-reader [rdr] (read-with-meta rdr sequence))) + clojure.lang.ASeq + "clj/aseq" + write-with-meta + (fn clj-seq-reader [rdr] (read-with-meta rdr sequence))) "clj/lazyseq" (create-identity-based-handler - clojure.lang.LazySeq - "clj/lazyseq" - write-with-meta - (fn clj-lazy-seq-reader [rdr] (read-with-meta rdr sequence))) + clojure.lang.LazySeq + "clj/lazyseq" + write-with-meta + (fn clj-lazy-seq-reader [rdr] (read-with-meta rdr sequence))) "clj/map" (create-identity-based-handler - clojure.lang.APersistentMap - "clj/map" - (fn clj-map-writer [wtr tag m] (write-with-meta wtr tag m write-map)) - (fn clj-map-reader [rdr] (read-with-meta rdr #(into {} %)))) + clojure.lang.APersistentMap + "clj/map" + (fn clj-map-writer [wtr tag m] (write-with-meta wtr tag m write-map)) + (fn clj-map-reader [rdr] (read-with-meta rdr #(into {} %)))) "clj/treeset" (create-identity-based-handler - clojure.lang.PersistentTreeSet - "clj/treeset" - (fn clj-treeset-writer [^Writer wtr tag s] - (let [cname (d/sorted-comparator-name s)] - (.writeTag wtr tag 3) - (if cname - (.writeObject wtr cname true) - (.writeNull wtr)) + clojure.lang.PersistentTreeSet + "clj/treeset" + (fn clj-treeset-writer [^Writer wtr tag s] + (let [cname (d/sorted-comparator-name s)] + (.writeTag wtr tag 3) + (if cname + (.writeObject wtr cname true) + (.writeNull wtr)) ;; Preserve metadata. - (if-let [m (meta s)] - (.writeObject wtr m) - (.writeNull wtr)) - (.writeList wtr s))) - (fn clj-treeset-reader [^Reader rdr] - (let [c (some-> rdr .readObject resolve deref) - m (.readObject rdr) - s (-> (.readObject rdr) - (d/seq->sorted-set c))] - (if m - (with-meta s m) - s)))) + (if-let [m (meta s)] + (.writeObject wtr m) + (.writeNull wtr)) + (.writeList wtr s))) + (fn clj-treeset-reader [^Reader rdr] + (let [c (some-> rdr .readObject resolve deref) + m (.readObject rdr) + s (-> (.readObject rdr) + (d/seq->sorted-set c))] + (if m + (with-meta s m) + s)))) "clj/treemap" (create-identity-based-handler - clojure.lang.PersistentTreeMap - "clj/treemap" - (fn clj-treemap-writer [^Writer wtr tag o] - (let [cname (d/sorted-comparator-name o)] - (.writeTag wtr tag 3) - (if cname - (.writeObject wtr cname true) - (.writeNull wtr)) + clojure.lang.PersistentTreeMap + "clj/treemap" + (fn clj-treemap-writer [^Writer wtr tag o] + (let [cname (d/sorted-comparator-name o)] + (.writeTag wtr tag 3) + (if cname + (.writeObject wtr cname true) + (.writeNull wtr)) ;; Preserve metadata. - (if-let [m (meta o)] - (.writeObject wtr m) - (.writeNull wtr)) - (write-map wtr o))) - (fn clj-treemap-reader [^Reader rdr] - (let [c (some-> rdr .readObject resolve deref) - m (.readObject rdr) - s (d/seq->sorted-map (.readObject rdr) c)] - (if m - (with-meta s m) - s)))) + (if-let [m (meta o)] + (.writeObject wtr m) + (.writeNull wtr)) + (write-map wtr o))) + (fn clj-treemap-reader [^Reader rdr] + (let [c (some-> rdr .readObject resolve deref) + m (.readObject rdr) + s (d/seq->sorted-map (.readObject rdr) c)] + (if m + (with-meta s m) + s)))) "clj/mapentry" (create-identity-based-handler - clojure.lang.MapEntry - "clj/mapentry" - (fn clj-mapentry-writer [^Writer wtr tag o] - (.writeTag wtr tag 2) - (.writeObject wtr (key o) true) - (.writeObject wtr (val o))) - (fn clj-mapentry-reader [^Reader rdr] - (d/create-map-entry (.readObject rdr) - (.readObject rdr)))) + clojure.lang.MapEntry + "clj/mapentry" + (fn clj-mapentry-writer [^Writer wtr tag o] + (.writeTag wtr tag 2) + (.writeObject wtr (key o) true) + (.writeObject wtr (val o))) + (fn clj-mapentry-reader [^Reader rdr] + (d/create-map-entry (.readObject rdr) + (.readObject rdr)))) ;; Have to redefine both Symbol and IRecord to support metadata as well ;; as identity-based caching for the IRecord case. "clj/sym" (create-identity-based-handler - clojure.lang.Symbol - "clj/sym" - (fn clj-sym-writer [^Writer wtr tag o] + clojure.lang.Symbol + "clj/sym" + (fn clj-sym-writer [^Writer wtr tag o] ;; Mostly copied from private fres/write-named, except the metadata part. - (.writeTag wtr tag 3) - (.writeObject wtr (namespace o) true) - (.writeObject wtr (name o) true) - (if-let [m (meta o)] - (.writeObject wtr m) - (.writeNull wtr))) - (fn clj-sym-reader [^Reader rdr] - (let [s (symbol (.readObject rdr) (.readObject rdr)) - m (read-meta rdr)] - (cond-> s - m (with-meta m))))) + (.writeTag wtr tag 3) + (.writeObject wtr (namespace o) true) + (.writeObject wtr (name o) true) + (if-let [m (meta o)] + (.writeObject wtr m) + (.writeNull wtr))) + (fn clj-sym-reader [^Reader rdr] + (let [s (symbol (.readObject rdr) (.readObject rdr)) + m (read-meta rdr)] + (cond-> s + m (with-meta m))))) "clj/record" (create-identity-based-handler - clojure.lang.IRecord - "clj/record" - write-record - read-record) + clojure.lang.IRecord + "clj/record" + write-record + read-record) "clara/productionnode" (create-cached-node-handler ProductionNode @@ -508,7 +538,7 @@ (def read-handlers "All Fressian read handlers used by FressianSessionSerializer's." - (->> handlers + (->> handlers vals (into fres/clojure-read-handlers (mapcat :readers)))) @@ -546,7 +576,7 @@ (pform/thread-local-binding [d/node-id->node-cache (volatile! {}) d/clj-struct-holder record-holder] (doseq [s sources] (fres/write-object wtr s)))))] - + ;; In this case there is nothing to do with memory, so just serialize immediately. (if (:rulebase-only? opts) ;; node-expr-fn-lookup is a map with a structure of: @@ -556,31 +586,30 @@ ;; during deserialization the compilation-context({Keyword Any}), which contains the unevaluated form, ;; can be used to reconstruct the original map. (do-serialize [(remove-node-fns node-expr-fn-lookup) rulebase]) - + ;; Otherwise memory needs to have facts extracted to return. (let [{:keys [memory indexed-facts internal-indexed-facts]} (d/indexed-session-memory-state memory) sources (if (:with-rulebase? opts) [(remove-node-fns node-expr-fn-lookup) rulebase internal-indexed-facts memory] [internal-indexed-facts memory])] - + (do-serialize sources) - + ;; Return the facts needing to be serialized still. indexed-facts)))) - + (deserialize [_ mem-facts opts] (with-open [^FressianReader rdr (fres/create-reader in-stream :handlers read-handler-lookup)] - (let [{:keys [rulebase-only? base-rulebase forms-per-eval]} opts - + (let [{:keys [rulebase-only? + base-rulebase]} opts + record-holder (ArrayList.) ;; The rulebase should either be given from the base-session or found in ;; the restored session-state. maybe-base-rulebase (when (and (not rulebase-only?) base-rulebase) base-rulebase) - forms-per-eval (or forms-per-eval com/forms-per-eval-default) - reconstruct-expressions (fn [expr-lookup] ;; Rebuilding the expr-lookup map from the serialized map: ;; {[Int Keyword] {Keyword Any}} -> {[Int Keyword] [SExpr {Keyword Any}]} @@ -596,12 +625,12 @@ d/clj-struct-holder record-holder] (pform/thread-local-binding [d/node-fn-cache (-> (fres/read-object rdr) reconstruct-expressions - (com/compile-exprs forms-per-eval))] + (com/compile-exprs opts))] (assoc (fres/read-object rdr) - :node-expr-fn-lookup - (.get d/node-fn-cache))))] + :node-expr-fn-lookup + (.get d/node-fn-cache))))] (d/rulebase->rulebase-with-opts without-opts-rulebase opts)))] - + (if rulebase-only? rulebase (d/assemble-restored-session rulebase diff --git a/src/main/clojure/clara/rules/engine.cljc b/src/main/clojure/clara/rules/engine.clj similarity index 78% rename from src/main/clojure/clara/rules/engine.cljc rename to src/main/clojure/clara/rules/engine.clj index b60f38f3..55f0e3ec 100644 --- a/src/main/clojure/clara/rules/engine.cljc +++ b/src/main/clojure/clara/rules/engine.clj @@ -1,15 +1,22 @@ (ns clara.rules.engine "This namespace is for internal use and may move in the future. Most users should use only the clara.rules namespace." - (:require [clojure.reflect :as reflect] - [clojure.core.reducers :as r] - [schema.core :as s] + (:require [clojure.core.reducers :as r] [clojure.string :as string] [clara.rules.memory :as mem] [clara.rules.listener :as l] - #?(:clj [clara.rules.platform :as platform] - :cljs [clara.rules.platform :as platform :include-macros true]) + [clara.rules.platform :as platform] [clara.rules.update-cache.core :as uc] - #?(:clj [clara.rules.update-cache.cancelling :as ca]))) + [clara.rules.update-cache.cancelling :as ca] + [futurama.core :refer [async + async? + async-future + async-cancelled? + > node - :children - (map get-conditions-and-rule-names) - (reduce (partial merge-with into) {}))))) + :children + (map get-conditions-and-rule-names) + (reduce (partial merge-with into) {}))))) ;; Active session during rule execution. (def ^:dynamic *current-session* nil) @@ -252,7 +248,10 @@ (defn- flush-updates "Flush all pending updates in the current session. Returns true if there were some items to flush, false otherwise" - [current-session] + [label current-session] + (when-not (-> current-session :pending-updates) + (throw (ex-info "session pending updates missing:" {:session current-session + :label label}))) (letfn [(flush-all [current-session flushed-items?] (let [{:keys [rulebase transient-memory transport insertions get-alphas-fn listener]} current-session pending-updates (-> current-session :pending-updates uc/get-updates-and-reset!)] @@ -280,15 +279,17 @@ "Place facts in a stateful cache to be inserted into the session immediately after the RHS of a rule fires." [facts unconditional] - (if unconditional - (swap! (:batched-unconditional-insertions *rule-context*) into facts) - (swap! (:batched-logical-insertions *rule-context*) into facts))) + (when *rule-context* + (if unconditional + (swap! (:batched-unconditional-insertions *rule-context*) into facts) + (swap! (:batched-logical-insertions *rule-context*) into facts)))) (defn rhs-retract-facts! "Place all facts retracted in the RHS in a buffer to be retracted after the eval'ed RHS function completes." [facts] - (swap! (:batched-rhs-retractions *rule-context*) into facts)) + (when *rule-context* + (swap! (:batched-rhs-retractions *rule-context*) into facts))) (defn ^:private flush-rhs-retractions! "Retract all facts retracted in the RHS after the eval'ed RHS function completes. @@ -348,8 +349,9 @@ (when (or (not (get-in production [:props :no-loop])) (not (= production (get-in *rule-context* [:node :production])))) - (let [activations (platform/eager-for [token tokens] - (->Activation node token))] + (let [activations (platform/eager-for + [token tokens] + (->Activation node token))] (l/add-activations! listener node activations) @@ -365,8 +367,9 @@ (l/left-retract! listener node tokens) ;; Remove pending activations triggered by the retracted tokens. - (let [activations (platform/eager-for [token tokens] - (->Activation node token)) + (let [activations (platform/eager-for + [token tokens] + (->Activation node token)) ;; We attempt to remove a pending activation for all tokens retracted, but our expectation ;; is that each token may remove a pending activation @@ -446,7 +449,6 @@ ITerminalNode (terminal-node-type [this] [:query (:name query)])) - (defn node-rule-names [child-type node] (->> node @@ -470,7 +472,6 @@ (if (pos? (count names)) (str prefix plural ":\n" names-string "\n")))) - (defn- single-condition-message [condition-number [condition-definition terminals]] (let [productions (->> terminals @@ -511,17 +512,16 @@ :conditions-and-rules conditions-and-rules} cause)))) -(defn- alpha-node-matches - [facts env activation node] - (platform/eager-for [fact facts - :let [bindings (try (activation fact env) - (catch #?(:clj Exception :cljs :default) e - (throw-condition-exception {:cause e - :node node - :fact fact - :env env})))] - :when bindings] ; FIXME: add env. - [fact bindings])) +(defn- alpha-node-match->Element + [fact env activation node] + (try + (when-let [bindings (activation fact env)] + (->Element fact bindings)) + (catch Exception e + (throw-condition-exception {:cause e + :node node + :fact fact + :env env})))) ;; Record representing alpha nodes in the Rete network, ;; each of which evaluates a single condition and @@ -530,38 +530,38 @@ IAlphaActivate (alpha-activate [node facts memory transport listener] - (let [fact-binding-pairs (alpha-node-matches facts env activation node)] - (l/alpha-activate! listener node (map first fact-binding-pairs)) + (let [match-elements (platform/compute-for + [fact facts] + (alpha-node-match->Element fact env activation node))] + (l/alpha-activate! listener node (map :fact match-elements)) (send-elements transport memory listener children - (platform/eager-for [[fact bindings] fact-binding-pairs] - (->Element fact bindings))))) + match-elements))) (alpha-retract [node facts memory transport listener] - (let [fact-binding-pairs (alpha-node-matches facts env activation node)] - (l/alpha-retract! listener node (map first fact-binding-pairs)) + (let [match-elements (platform/compute-for + [fact facts] + (alpha-node-match->Element fact env activation node))] + (l/alpha-retract! listener node (map :fact match-elements)) (retract-elements - transport - memory - listener - children - (platform/eager-for [[fact bindings] fact-binding-pairs] - (->Element fact bindings)))))) + transport + memory + listener + children + match-elements)))) (defrecord RootJoinNode [id condition children binding-keys] ILeftActivate - (left-activate [node join-bindings tokens memory transport listener] + (left-activate [node join-bindings tokens memory transport listener]) ;; This specialized root node doesn't need to deal with the ;; empty token, so do nothing. - ) - (left-retract [node join-bindings tokens memory transport listener] + (left-retract [node join-bindings tokens memory transport listener]) ;; The empty token can't be retracted from the root node, ;; so do nothing. - ) (get-join-keys [node] binding-keys) @@ -572,7 +572,6 @@ (l/right-activate! listener node elements) - ;; Add elements to the working memory to support analysis tools. (mem/add-elements! memory node join-bindings elements) ;; Simply create tokens and send it downstream. @@ -581,8 +580,9 @@ memory listener children - (platform/eager-for [{:keys [fact bindings] :as element} elements] - (->Token [[fact (:id node)]] bindings)))) + (platform/eager-for + [{:keys [fact bindings] :as element} elements] + (->Token [[fact (:id node)]] bindings)))) (right-retract [node join-bindings elements memory transport listener] @@ -594,8 +594,9 @@ memory listener children - (platform/eager-for [{:keys [fact bindings] :as element} (mem/remove-elements! memory node join-bindings elements)] - (->Token [[fact (:id node)]] bindings)))) + (platform/eager-for + [{:keys [fact bindings] :as element} (mem/remove-elements! memory node join-bindings elements)] + (->Token [[fact (:id node)]] bindings)))) IConditionNode (get-condition-description [this] @@ -616,11 +617,12 @@ memory listener children - (platform/eager-for [element (mem/get-elements memory node join-bindings) - token tokens - :let [fact (:fact element) - fact-binding (:bindings element)]] - (->Token (conj (:matches token) [fact id]) (conj fact-binding (:bindings token)))))) + (platform/eager-for + [element (mem/get-elements memory node join-bindings) + token tokens + :let [fact (:fact element) + fact-binding (:bindings element)]] + (->Token (conj (:matches token) [fact id]) (conj fact-binding (:bindings token)))))) (left-retract [node join-bindings tokens memory transport listener] (l/left-retract! listener node tokens) @@ -629,11 +631,12 @@ memory listener children - (platform/eager-for [token (mem/remove-tokens! memory node join-bindings tokens) - element (mem/get-elements memory node join-bindings) - :let [fact (:fact element) - fact-bindings (:bindings element)]] - (->Token (conj (:matches token) [fact id]) (conj fact-bindings (:bindings token)))))) + (platform/eager-for + [token (mem/remove-tokens! memory node join-bindings tokens) + element (mem/get-elements memory node join-bindings) + :let [fact (:fact element) + fact-bindings (:bindings element)]] + (->Token (conj (:matches token) [fact id]) (conj fact-bindings (:bindings token)))))) (get-join-keys [node] binding-keys) @@ -648,9 +651,10 @@ memory listener children - (platform/eager-for [token (mem/get-tokens memory node join-bindings) - {:keys [fact bindings] :as element} elements] - (->Token (conj (:matches token) [fact id]) (conj (:bindings token) bindings))))) + (platform/eager-for + [token (mem/get-tokens memory node join-bindings) + {:keys [fact bindings] :as element} elements] + (->Token (conj (:matches token) [fact id]) (conj (:bindings token) bindings))))) (right-retract [node join-bindings elements memory transport listener] (l/right-retract! listener node elements) @@ -659,9 +663,10 @@ memory listener children - (platform/eager-for [{:keys [fact bindings] :as element} (mem/remove-elements! memory node join-bindings elements) - token (mem/get-tokens memory node join-bindings)] - (->Token (conj (:matches token) [fact id]) (conj (:bindings token) bindings))))) + (platform/eager-for + [{:keys [fact bindings] :as element} (mem/remove-elements! memory node join-bindings elements) + token (mem/get-tokens memory node join-bindings)] + (->Token (conj (:matches token) [fact id]) (conj (:bindings token) bindings))))) IConditionNode (get-condition-description [this] @@ -671,50 +676,56 @@ (defn- join-node-matches [node join-filter-fn token fact fact-bindings env] (let [beta-bindings (try (join-filter-fn token fact fact-bindings {}) - (catch #?(:clj Exception :cljs :default) e - (throw-condition-exception {:cause e - :node node - :fact fact - :env env - :bindings (merge (:bindings token) - fact-bindings)})))] + (catch Exception e + (throw-condition-exception {:cause e + :node node + :fact fact + :env env + :bindings (merge (:bindings token) + fact-bindings)})))] beta-bindings)) +(defn- expression-join-node-match->Token + [element token node id join-filter-fn env] + (let [fact (:fact element) + fact-binding (:bindings element) + beta-bindings (join-node-matches node join-filter-fn token fact fact-binding env)] + (when beta-bindings + (->Token (conj (:matches token) [fact id]) + (conj fact-binding (:bindings token) beta-bindings))))) + (defrecord ExpressionJoinNode [id condition join-filter-fn children binding-keys] ILeftActivate (left-activate [node join-bindings tokens memory transport listener] ;; Add token to the node's working memory for future right activations. (mem/add-tokens! memory node join-bindings tokens) (l/left-activate! listener node tokens) - (send-tokens - transport - memory - listener - children - (platform/eager-for [element (mem/get-elements memory node join-bindings) - token tokens - :let [fact (:fact element) - fact-binding (:bindings element) - beta-bindings (join-node-matches node join-filter-fn token fact fact-binding {})] - :when beta-bindings] - (->Token (conj (:matches token) [fact id]) - (conj fact-binding (:bindings token) beta-bindings))))) + (let [elements (mem/get-elements memory node join-bindings) + matched-tokens (platform/compute-for + [element elements + token tokens] + (expression-join-node-match->Token element token node id join-filter-fn (:env condition)))] + (send-tokens + transport + memory + listener + children + matched-tokens))) (left-retract [node join-bindings tokens memory transport listener] (l/left-retract! listener node tokens) - (retract-tokens - transport - memory - listener - children - (platform/eager-for [token (mem/remove-tokens! memory node join-bindings tokens) - element (mem/get-elements memory node join-bindings) - :let [fact (:fact element) - fact-bindings (:bindings element) - beta-bindings (join-node-matches node join-filter-fn token fact fact-bindings {})] - :when beta-bindings] - (->Token (conj (:matches token) [fact id]) - (conj fact-bindings (:bindings token) beta-bindings))))) + (let [tokens (mem/remove-tokens! memory node join-bindings tokens) + elements (mem/get-elements memory node join-bindings) + matched-tokens (platform/compute-for + [element elements + token tokens] + (expression-join-node-match->Token element token node id join-filter-fn (:env condition)))] + (retract-tokens + transport + memory + listener + children + matched-tokens))) (get-join-keys [node] binding-keys) @@ -722,33 +733,34 @@ IRightActivate (right-activate [node join-bindings elements memory transport listener] - (mem/add-elements! memory node join-bindings elements) - (l/right-activate! listener node elements) - (send-tokens - transport - memory - listener - children - (platform/eager-for [token (mem/get-tokens memory node join-bindings) - {:keys [fact bindings] :as element} elements - :let [beta-bindings (join-node-matches node join-filter-fn token fact bindings {})] - :when beta-bindings] - (->Token (conj (:matches token) [fact id]) - (conj (:bindings token) bindings beta-bindings))))) + (let [tokens (mem/get-tokens memory node join-bindings) + matched-tokens (platform/compute-for + [element elements + token tokens] + (expression-join-node-match->Token element token node id join-filter-fn (:env condition)))] + (mem/add-elements! memory node join-bindings elements) + (l/right-activate! listener node elements) + (send-tokens + transport + memory + listener + children + matched-tokens))) (right-retract [node join-bindings elements memory transport listener] (l/right-retract! listener node elements) - (retract-tokens - transport - memory - listener - children - (platform/eager-for [{:keys [fact bindings] :as element} (mem/remove-elements! memory node join-bindings elements) - token (mem/get-tokens memory node join-bindings) - :let [beta-bindings (join-node-matches node join-filter-fn token fact bindings {})] - :when beta-bindings] - (->Token (conj (:matches token) [fact id]) - (conj (:bindings token) bindings beta-bindings))))) + (let [elements (mem/remove-elements! memory node join-bindings elements) + tokens (mem/get-tokens memory node join-bindings) + matched-tokens (platform/compute-for + [element elements + token tokens] + (expression-join-node-match->Token element token node id join-filter-fn (:env condition)))] + (retract-tokens + transport + memory + listener + children + matched-tokens))) IConditionNode (get-condition-description [this] @@ -804,12 +816,13 @@ (let [{:keys [type constraints]} condition] [:not (into [type] constraints)]))) -(defn- matches-some-facts? - "Returns true if the given token matches one or more of the given elements." +(defn- negation-join-node-not-match->Token [node token elements join-filter-fn condition] - (some (fn [{:keys [fact bindings]}] - (join-node-matches node join-filter-fn token fact bindings (:env condition))) - elements)) + (when-not (some (fn negation-join-match + [{:keys [fact bindings]}] + (join-node-matches node join-filter-fn token fact bindings (:env condition))) + elements) + token)) ;; A specialization of the NegationNode that supports additional tests ;; that have to occur on the beta side of the network. The key difference between this and the simple @@ -828,13 +841,13 @@ listener children (let [elements (mem/get-elements memory node join-bindings)] - (platform/eager-for [token tokens - :when (not (matches-some-facts? node - token - elements - join-filter-fn - condition))] - token)))) + (platform/compute-for + [token tokens] + (negation-join-node-not-match->Token node + token + elements + join-filter-fn + condition))))) (left-retract [node join-bindings tokens memory transport listener] (l/left-retract! listener node tokens) @@ -843,17 +856,16 @@ memory listener children - ;; Retract only if it previously had no matches in the negation node, ;; and therefore had an activation. (let [elements (mem/get-elements memory node join-bindings)] - (platform/eager-for [token tokens - :when (not (matches-some-facts? node - token - elements - join-filter-fn - condition))] - token)))) + (platform/compute-for + [token tokens] + (negation-join-node-not-match->Token node + token + elements + join-filter-fn + condition))))) (get-join-keys [node] binding-keys) @@ -868,24 +880,23 @@ memory listener children - (platform/eager-for [token (mem/get-tokens memory node join-bindings) - - ;; Retract downstream if the token now has matching elements and didn't before. - ;; We check the new elements first in the expectation that the new elements will be - ;; smaller than the previous elements most of the time - ;; and that the time to check the elements will be proportional - ;; to the number of elements. - :when (and (matches-some-facts? node - token - elements - join-filter-fn - condition) - (not (matches-some-facts? node - token - previous-elements - join-filter-fn - condition)))] - token)) + (platform/compute-for + [token (mem/get-tokens memory node join-bindings)] + ;; Retract downstream if the token now has matching elements and didn't before. + ;; We check the new elements first in the expectation that the new elements will be + ;; smaller than the previous elements most of the time + ;; and that the time to check the elements will be proportional + ;; to the number of elements. + (when-not (negation-join-node-not-match->Token node + token + elements + join-filter-fn + condition) + (negation-join-node-not-match->Token node + token + previous-elements + join-filter-fn + condition)))) ;; Adding the elements will mutate the previous-elements since, on the JVM, the LocalMemory ;; currently returns a mutable List from get-elements after changes in issue 184. We need to use the ;; new and old elements in the logic above as separate collections. Therefore we need to delay updating the @@ -902,21 +913,20 @@ listener children (let [remaining-elements (mem/get-elements memory node join-bindings)] - (platform/eager-for [token (mem/get-tokens memory node join-bindings) - - ;; Propagate tokens when some of the retracted facts joined - ;; but none of the remaining facts do. - :when (and (matches-some-facts? node - token - elements - join-filter-fn - condition) - (not (matches-some-facts? node - token - remaining-elements - join-filter-fn - condition)))] - token)))) + (platform/compute-for + [token (mem/get-tokens memory node join-bindings)] + ;; Propagate tokens when some of the retracted facts joined + ;; but none of the remaining facts do. + (when-not (negation-join-node-not-match->Token node + token + elements + join-filter-fn + condition) + (negation-join-node-not-match->Token node + token + remaining-elements + join-filter-fn + condition)))))) IConditionNode (get-condition-description [this] @@ -926,16 +936,17 @@ constraints)] [:not (into [type] full-constraints)]))) -(defn- test-node-matches +(defn- test-node-match->Token [node test-handler env token] (let [test-result (try (test-handler token env) - (catch #?(:clj Exception :cljs :default) e + (catch Exception e (throw-condition-exception {:cause e :node node :env env :bindings (:bindings token)})))] - test-result)) + (when test-result + token))) ;; The test node represents a Rete extension in which an arbitrary test condition is run ;; against bindings from ancestor nodes. Since this node @@ -949,10 +960,9 @@ memory listener children - (platform/eager-for - [token tokens - :when (test-node-matches node test env token)] - token))) + (platform/compute-for + [token tokens] + (test-node-match->Token node test env token)))) (left-retract [node join-bindings tokens memory transport listener] (l/left-retract! listener node tokens) @@ -980,8 +990,8 @@ new-bindings (merge (:bindings token) fact-bindings (when result-binding - { result-binding - converted-result}))] + {result-binding + converted-result}))] (retract-tokens transport memory listener (:children node) [(->Token new-facts new-bindings)]))) @@ -992,7 +1002,7 @@ (let [new-bindings (merge (:bindings token) fact-bindings (when result-binding - { result-binding + {result-binding converted-result})) ;; This is to check that the produced accumulator result is @@ -1132,8 +1142,9 @@ IAccumRightActivate (pre-reduce [node elements] ;; Return a seq tuples with the form [binding-group facts-from-group-elements]. - (platform/eager-for [[bindings element-group] (platform/group-by-seq :bindings elements)] - [bindings (mapv :fact element-group)])) + (platform/eager-for + [[bindings element-group] (platform/group-by-seq :bindings elements)] + [bindings (mapv :fact element-group)])) (right-activate-reduced [node join-bindings fact-seq memory transport listener] @@ -1211,8 +1222,7 @@ (send-accumulated node accum-condition accumulator result-binding token converted bindings transport memory listener)) - - ;; If there are previous results, then propagate downstream if the new result differs from +;; If there are previous results, then propagate downstream if the new result differs from ;; the previous result. If the new result is equal to the previous result don't do ;; anything. Note that the memory has already been updated with the new combined value, ;; which may be needed if elements in memory changes later. @@ -1445,7 +1455,7 @@ converted-result join-bindings transport memory listener)))) ;; Propagate nothing if the above conditions don't apply. - :default nil))) + :else nil))) (left-retract [node join-bindings tokens memory transport listener] @@ -1504,8 +1514,9 @@ ;; Return a map of bindings to the candidate facts that match them. This accumulator ;; depends on the values from parent facts, so we defer actually running the accumulator ;; until we have a token. - (platform/eager-for [[bindings element-group] (platform/group-by-seq :bindings elements)] - [bindings (map :fact element-group)])) + (platform/eager-for + [[bindings element-group] (platform/group-by-seq :bindings elements)] + [bindings (map :fact element-group)])) (right-activate-reduced [node join-bindings binding-candidates-seq memory transport listener] @@ -1733,177 +1744,206 @@ "NegationWithJoinFilterNode" "NJFN" "ExpressionJoinNode" "EJN"}) -(defn variables-as-keywords - "Returns symbols in the given s-expression that start with '?' as keywords" - [expression] - (into #{} (platform/eager-for [item (tree-seq coll? seq expression) - :when (and (symbol? item) - (= \? (first (name item))))] - (keyword item)))) - -(defn conj-rulebases - "DEPRECATED. Simply concat sequences of rules and queries. - - Conjoin two rulebases, returning a new one with the same rules." - [base1 base2] - (concat base1 base2)) - -(defn fire-rules* - "Fire rules for the given nodes." - [rulebase nodes transient-memory transport listener get-alphas-fn update-cache] - (binding [*current-session* {:rulebase rulebase - :transient-memory transient-memory - :transport transport - :insertions (atom 0) - :get-alphas-fn get-alphas-fn - :pending-updates update-cache - :listener listener}] - - (loop [next-group (mem/next-activation-group transient-memory) - last-group nil] - - (if next-group - - (if (and last-group (not= last-group next-group)) - - ;; We have changed groups, so flush the updates from the previous - ;; group before continuing. - (do - (flush-updates *current-session*) - (let [upcoming-group (mem/next-activation-group transient-memory)] - (l/activation-group-transition! listener next-group upcoming-group) - (recur upcoming-group next-group))) - - (do - - ;; If there are activations, fire them. - (when-let [{:keys [node token] :as activation} (mem/pop-activation! transient-memory)] - ;; Use vectors for the insertion caches so that within an insertion type - ;; (unconditional or logical) all insertions are done in order after the into - ;; calls in insert-facts!. This shouldn't have a functional impact, since any ordering - ;; should be valid, but makes traces less confusing to end users. It also prevents any laziness - ;; in the sequences. - (let [batched-logical-insertions (atom []) - batched-unconditional-insertions (atom []) - batched-rhs-retractions (atom [])] - (binding [*rule-context* {:token token - :node node - :batched-logical-insertions batched-logical-insertions - :batched-unconditional-insertions batched-unconditional-insertions - :batched-rhs-retractions batched-rhs-retractions}] - - ;; Fire the rule itself. - (try - ((:rhs node) token (:env (:production node))) - ;; Don't do anything if a given insertion type has no corresponding - ;; facts to avoid complicating traces. Note that since each no RHS's of - ;; downstream rules are fired here everything is governed by truth maintenance. - ;; Therefore, the reordering of retractions and insertions should have no impact - ;; assuming that the evaluation of rule conditions is pure, which is a general expectation - ;; of the rules engine. - ;; - ;; Bind the contents of the cache atoms after the RHS is fired since they are used twice - ;; below. They will be dereferenced again if an exception is caught, but in the error - ;; case we aren't worried about performance. - (let [retrieved-unconditional-insertions @batched-unconditional-insertions - retrieved-logical-insertions @batched-logical-insertions - retrieved-rhs-retractions @batched-rhs-retractions] - (l/fire-activation! listener - activation - {:unconditional-insertions retrieved-unconditional-insertions - :logical-insertions retrieved-logical-insertions - :rhs-retractions retrieved-rhs-retractions}) - (when-let [batched (seq retrieved-unconditional-insertions)] - (flush-insertions! batched true)) - (when-let [batched (seq retrieved-logical-insertions)] - (flush-insertions! batched false)) - (when-let [batched (seq retrieved-rhs-retractions)] - (flush-rhs-retractions! batched))) - (catch #?(:clj Exception :cljs :default) e - - ;; If the rule fired an exception, help debugging by attaching - ;; details about the rule itself, cached insertions, and any listeners - ;; while propagating the cause. - (let [production (:production node) - rule-name (:name production) - rhs (:rhs production)] - (throw (ex-info (str "Exception in " (if rule-name rule-name (pr-str rhs)) - " with bindings " (pr-str (:bindings token))) - {:bindings (:bindings token) - :name rule-name - :rhs rhs - :batched-logical-insertions @batched-logical-insertions - :batched-unconditional-insertions @batched-unconditional-insertions - :batched-rhs-retractions @batched-rhs-retractions - :listeners (try - (let [p-listener (l/to-persistent! listener)] - (if (l/null-listener? p-listener) - [] - (l/get-children p-listener))) - (catch #?(:clj Exception :cljs :default) - listener-exception - listener-exception))} - e))))) - - ;; Explicitly flush updates if we are in a no-loop rule, so the no-loop - ;; will be in context for child rules. - (when (some-> node :production :props :no-loop) - (flush-updates *current-session*))))) - - (recur (mem/next-activation-group transient-memory) next-group))) - - ;; There were no items to be activated, so flush any pending - ;; updates and recur with a potential new activation group - ;; since a flushed item may have triggered one. - (when (flush-updates *current-session*) - (let [upcoming-group (mem/next-activation-group transient-memory)] - (l/activation-group-transition! listener next-group upcoming-group) - (recur upcoming-group next-group))))))) - -(deftype LocalSession [rulebase memory transport listener get-alphas-fn pending-operations] - ISession - (insert [session facts] - - (let [new-pending-operations (conj pending-operations (uc/->PendingUpdate :insertion - ;; Preserve the behavior prior to https://github.com/cerner/clara-rules/issues/268 - ;; , particularly for the Java API, where the caller could freely mutate a - ;; collection of facts after passing it to Clara for the constituent - ;; facts to be inserted or retracted. If the caller passes a persistent - ;; Clojure collection don't do any additional work. - (if (coll? facts) - facts - (into [] facts))))] - - (LocalSession. rulebase - memory - transport - listener - get-alphas-fn - new-pending-operations))) - - (retract [session facts] - - (let [new-pending-operations (conj pending-operations (uc/->PendingUpdate :retraction - ;; As in insert above defend against facts being a mutable collection. - (if (coll? facts) - facts - (into [] facts))))] - - (LocalSession. rulebase - memory - transport - listener - get-alphas-fn - new-pending-operations))) - - ;; Prior to issue 249 we only had a one-argument fire-rules method. clara.rules/fire-rules will always call the two-argument method now - ;; but we kept a one-argument version of the fire-rules in case anyone is calling the fire-rules protocol function or method on the session directly. - (fire-rules [session] (fire-rules session {})) - (fire-rules [session opts] - - (let [transient-memory (mem/to-transient memory) - transient-listener (l/to-transient listener)] - +(defn- ->activation-output + "Bind the contents of the cache atoms after the RHS is fired since they are used to send to the listener + and then again to flush updates. They will be dereferenced again if an exception is caught, but in the error + case we aren't worried about performance." + [activation _result] + (let [{:keys [node + token]} activation + {:keys [listener]} *current-session* + {:keys [batched-logical-insertions + batched-rhs-retractions + batched-unconditional-insertions]} *rule-context* + resulting-ops {:unconditional-insertions @batched-unconditional-insertions + :logical-insertions @batched-logical-insertions + :rhs-retractions @batched-rhs-retractions}] + (l/fire-activation! listener activation resulting-ops) + {:token token :node node :ops resulting-ops})) + +(defn- throw-activation-exception + "If the rule fired an exception, help debugging by attaching + details about the rule itself, cached insertions, and any listeners + while propagating the cause." + [activation exception] + (let [{:keys [node + token]} activation + {:keys [listener]} *current-session* + {:keys [batched-logical-insertions + batched-rhs-retractions + batched-unconditional-insertions]} *rule-context* + production (:production node) + rule-name (:name production) + rhs (:rhs production)] + (throw (ex-info + (str "Exception in " (if rule-name rule-name (pr-str rhs)) + " with bindings " (pr-str (:bindings token))) + {:bindings (:bindings token) + :name rule-name + :rhs rhs + :batched-logical-insertions @batched-logical-insertions + :batched-unconditional-insertions @batched-unconditional-insertions + :batched-rhs-retractions @batched-rhs-retractions + :listeners (try + (let [p-listener (l/to-persistent! listener)] + (if (l/null-listener? p-listener) + [] + (l/get-children p-listener))) + (catch Exception listener-exception + listener-exception))} + exception)))) + +(defn- fire-activation! + "Fire the rule's RHS represented by the activation node, + if an activation returns an async result then it is handled + by blocking until it completes." + [activation] + (let [{:keys [node + token]} activation] + (try + (when (async-cancelled?) + (throw (InterruptedException. "Activation cancelled."))) + ;; Actually fire the rule RHS + (let [result ((:rhs node) token (:env (:production node)))] + (if (async? result) + (->activation-output activation (!activation-output activation result))) + (catch Exception e + (throw-activation-exception activation e))))) + +(defn- fire-activation-async! + "Fire the rule's RHS represented by the activation node, + if an activation returns an async result then it is handled + without blocking and the call returns an async result as well." + [activation] + (let [{:keys [node + token]} activation] + (try + (when (async-cancelled?) + (throw (InterruptedException. "Activation cancelled."))) + ;; Actually fire the rule RHS + (let [result ((:rhs node) token (:env (:production node)))] + (if (async? result) + (async + (try + (->activation-output activation (!activation-output activation result)))) + (catch Exception e + (throw-activation-exception activation e))))) + +(defn- ->activation-rule-context + "Use vectors for the insertion caches so that within an insertion type + (unconditional or logical) all insertions are done in order after the into + calls in insert-facts!. This shouldn't have a functional impact, since any ordering + should be valid, but makes traces less confusing to end users. + It also prevents any laziness in the sequences." + [{:keys [node token]} to-fire-rules] + (cond-> {:token token + :node node} + to-fire-rules + (assoc :batched-logical-insertions (atom []) + :batched-unconditional-insertions (atom []) + :batched-rhs-retractions (atom [])))) + +(defn- fire-activations! + "fire all activations in order" + [activations] + (platform/eager-for + [activation activations] + ;;; this the production expression, which could return an async result if parallel computing + (binding [*rule-context* (->activation-rule-context activation true)] + (fire-activation! activation)))) + +(defn- fire-activations-async! + "fire all activations in order" + [activations] + (platform/eager-for + [activation activations] + ;;; this the production expression, which could return an async result if parallel computing + (binding [*rule-context* (->activation-rule-context activation true)] + (fire-activation-async! activation)))) + +(defn- process-activations! + "Flush the changes and updates made during activation of the rules" + [rhs-activations] + (doseq [{:keys [token node ops]} rhs-activations + :let [{:keys [unconditional-insertions + logical-insertions + rhs-retractions]} ops]] + (binding [*rule-context* {:token token + :node node}] + (when-let [batched (seq unconditional-insertions)] + (flush-insertions! batched true)) + (when-let [batched (seq logical-insertions)] + (flush-insertions! batched false)) + (when-let [batched (seq rhs-retractions)] + (flush-rhs-retractions! batched)) + ;; Explicitly flush updates if we are in a no-loop rule, so the no-loop + ;; will be in context for child rules. + (when (some-> node :production :props :no-loop) + (flush-updates :process-activations *current-session*))))) + +(defmacro ^:private do-fire-rules + "Instrument a session to fire rules activations then execute the fire-activations-body" + [memory listener & fire-activations-body] + `(loop [next-group# (mem/next-activation-group ~memory) + last-group# nil] + (if next-group# + (if (and last-group# (not= last-group# next-group#)) + ;; We have changed groups, so flush the updates from the previous + ;; group before continuing. + (do + (flush-updates :changed-group *current-session*) + (let [upcoming-group# (mem/next-activation-group ~memory)] + (l/activation-group-transition! ~listener next-group# upcoming-group#) + (recur upcoming-group# next-group#))) + (do + ;; If there are activations, fire them. + ~@fire-activations-body + (recur (mem/next-activation-group ~memory) next-group#))) + ;; There were no items to be activated, so flush any pending + ;; updates and recur with a potential new activation group + ;; since a flushed item may have triggered one. + (when (flush-updates :changing-groups *current-session*) + (let [upcoming-group# (mem/next-activation-group ~memory)] + (l/activation-group-transition! ~listener next-group# upcoming-group#) + (recur upcoming-group# next-group#)))))) + +(defn- fire-rules! + "Fire rules for the given nodes, sequentially one at a time" + [{:keys [transient-memory listener]} _options] + (do-fire-rules + transient-memory listener + (let [activations (mem/pop-activations! transient-memory 1) + rhs-activations (fire-activations! activations)] + (process-activations! rhs-activations)))) + +(defn- fire-rules-async! + "Fire rules for the given nodes supporting async behavior." + [{:keys [transient-memory listener]} options] + (async + (do-fire-rules + transient-memory listener + (let [pop-activations-batch-size (or (:parallel-batch-size options) 1) + activations (mem/pop-activations! transient-memory pop-activations-batch-size) + rhs-activations (fire-activations-async! activations)] + (process-activations! (LocalSession) - (fire-rules* rulebase - (:production-nodes rulebase) - transient-memory +(deftype LocalSession [rulebase memory transport listener get-alphas-fn pending-operations] + ISession + (insert [session facts] + + (let [new-pending-operations (conj pending-operations (uc/->PendingUpdate :insertion + ;; Preserve the behavior prior to https://github.com/cerner/clara-rules/issues/268 + ;; , particularly for the Java API, where the caller could freely mutate a + ;; collection of facts after passing it to Clara for the constituent + ;; facts to be inserted or retracted. If the caller passes a persistent + ;; Clojure collection don't do any additional work. + (if (coll? facts) + facts + (into [] facts))))] + + (->LocalSession rulebase + memory + transport + listener + get-alphas-fn + new-pending-operations))) + + (retract [session facts] + + (let [new-pending-operations (conj pending-operations (uc/->PendingUpdate :retraction + ;; As in insert above defend against facts being a mutable collection. + (if (coll? facts) + facts + (into [] facts))))] + + (->LocalSession rulebase + memory + transport + listener + get-alphas-fn + new-pending-operations))) + + ;; Prior to issue 249 we only had a one-argument fire-rules method. clara.rules/fire-rules will always call the two-argument method now + ;; but we kept a one-argument version of the fire-rules in case anyone is calling the fire-rules protocol function or method on the session directly. + (fire-rules [session] + (fire-rules session {})) + (fire-rules [session opts] + (let [transient-memory (mem/to-transient memory) + transient-listener (l/to-transient listener)] + (fire-rules* + rulebase transient-memory transport + transient-listener get-alphas-fn + pending-operations opts + fire-rules!) + (->LocalSession rulebase + (mem/to-persistent! transient-memory) + transport + (l/to-persistent! transient-listener) + get-alphas-fn + []))) + ;; These return CompletableFuture async results + (fire-rules-async [session] + (fire-rules-async session {})) + (fire-rules-async [session opts] + (async-future + (let [transient-memory (mem/to-transient memory) + transient-listener (l/to-transient listener)] + (LocalSession rulebase + (mem/to-persistent! transient-memory) transport - transient-listener + (l/to-persistent! transient-listener) get-alphas-fn - (uc/get-ordered-update-cache))) - - #?(:cljs (throw (ex-info "The :cancelling option is not supported in ClojureScript" - {:session session :opts opts})) - - :clj (let [insertions (sequence - (comp (filter (fn [pending-op] - (= (:type pending-op) - :insertion))) - (mapcat :facts)) - pending-operations) - - retractions (sequence - (comp (filter (fn [pending-op] - (= (:type pending-op) - :retraction))) - (mapcat :facts)) - pending-operations) - - update-cache (ca/get-cancelling-update-cache)] - - (binding [*current-session* {:rulebase rulebase - :transient-memory transient-memory - :transport transport - :insertions (atom 0) - :get-alphas-fn get-alphas-fn - :pending-updates update-cache - :listener transient-listener}] - - ;; Insertions should come before retractions so that if we insert and then retract the same - ;; fact that is not already in the session the end result will be that the session won't have that fact. - ;; If retractions came first then we'd first retract a fact that isn't in the session, which doesn't do anything, - ;; and then later we would insert the fact. - (doseq [[alpha-roots fact-group] (get-alphas-fn insertions) - root alpha-roots] - (alpha-activate root fact-group transient-memory transport transient-listener)) - - (doseq [[alpha-roots fact-group] (get-alphas-fn retractions) - root alpha-roots] - (alpha-retract root fact-group transient-memory transport transient-listener)) - - (fire-rules* rulebase - (:production-nodes rulebase) - transient-memory - transport - transient-listener - get-alphas-fn - ;; This continues to use the cancelling cache after the first batch of insertions and retractions. - ;; If this is suboptimal for some workflows we can revisit this. - update-cache))))) - - (LocalSession. rulebase - (mem/to-persistent! transient-memory) - transport - (l/to-persistent! transient-listener) - get-alphas-fn - []))) + [])))) (query [session query params] (let [query-node (get-in rulebase [:query-nodes query])] @@ -2033,6 +2112,10 @@ :listeners (l/flatten-listener listener) :get-alphas-fn get-alphas-fn})) +(defn ->LocalSession + [rulebase memory transport listener get-alphas-fn pending-operations] + (LocalSession. rulebase memory transport listener get-alphas-fn pending-operations)) + (defn assemble "Assembles a session from the given components, which must be a map containing the following: @@ -2044,14 +2127,14 @@ :get-alphas-fn The function used to return the alpha nodes for a fact of the given type." [{:keys [rulebase memory transport listeners get-alphas-fn]}] - (LocalSession. rulebase - memory - transport - (if (> (count listeners) 0) - (l/delegating-listener listeners) - l/default-listener) - get-alphas-fn - [])) + (->LocalSession rulebase + memory + transport + (if (> (count listeners) 0) + (l/delegating-listener listeners) + l/default-listener) + get-alphas-fn + [])) (defn with-listener "Return a new session with the listener added to the provided session, diff --git a/src/main/clojure/clara/rules/java.clj b/src/main/clojure/clara/rules/java.clj index eb299d2b..533409cd 100644 --- a/src/main/clojure/clara/rules/java.clj +++ b/src/main/clojure/clara/rules/java.clj @@ -3,11 +3,9 @@ Java support. Users should use the Java API, or the clara.rules namespace from Clojure." (:require [clara.rules :as clara] [clara.rules.engine :as eng] - [clara.rules.compiler :as com] - [clara.rules.memory :as mem]) + [clara.rules.compiler :as com]) (:refer-clojure :exclude [==]) - (:import [clara.rules.engine LocalTransport] - [clara.rules WorkingMemory QueryResult])) + (:import [clara.rules WorkingMemory QueryResult])) (deftype JavaQueryResult [result] QueryResult @@ -42,10 +40,10 @@ (JavaWorkingMemory. (clara/fire-rules session))) (query [this name args] - (run-query session name args)) + (run-query session name args)) (query [this name] - (run-query session name {}))) + (run-query session name {}))) (defn mk-java-session [rulesets] (JavaWorkingMemory. diff --git a/src/main/clojure/clara/rules/listener.cljc b/src/main/clojure/clara/rules/listener.clj similarity index 99% rename from src/main/clojure/clara/rules/listener.cljc rename to src/main/clojure/clara/rules/listener.clj index 0161e58a..a5b1368d 100644 --- a/src/main/clojure/clara/rules/listener.cljc +++ b/src/main/clojure/clara/rules/listener.clj @@ -94,7 +94,7 @@ (insert-facts! [listener node token facts] (doseq [child children] (insert-facts! child node token facts))) - + (alpha-activate! [listener node facts] (doseq [child children] (alpha-activate! child node facts))) @@ -106,7 +106,7 @@ (retract-facts! [listener node token facts] (doseq [child children] (retract-facts! child node token facts))) - + (alpha-retract! [listener node facts] (doseq [child children] (alpha-retract! child node facts))) diff --git a/src/main/clojure/clara/rules/memory.clj b/src/main/clojure/clara/rules/memory.clj new file mode 100644 index 00000000..26fb78b6 --- /dev/null +++ b/src/main/clojure/clara/rules/memory.clj @@ -0,0 +1,906 @@ +(ns clara.rules.memory + "This namespace is for internal use and may move in the future. + Specification and default implementation of working memory" + (:require [ham-fisted.api :as hf] + [ham-fisted.mut-map :as hm]) + (:import [java.util + Map + List + Collections + LinkedList + NavigableMap + PriorityQueue + TreeMap] + [ham_fisted MutableMap])) + +(defprotocol IPersistentMemory + (to-transient [memory])) + +(defprotocol IMemoryReader + ;; Returns the rulebase associated with the given memory. + (get-rulebase [memory]) + + ;; Returns a function that produces a map of alpha nodes to + ;; facts that match the type of the node + (get-alphas-fn [memory]) + + ;; Returns the elements assoicated with the given node. + (get-elements [memory node bindings]) + + ;; Returns all elements associated with the given node, regardless of bindings. + (get-elements-all [memory node]) + + ;; Returns the tokens associated with the given node. + (get-tokens [memory node bindings]) + + ;; Returns all tokens associated with the given node, regardless of bindings + (get-tokens-all [memory node]) + + ;; Returns the reduced form of objects processed by an accumulator node + ;; for facts that match the given bindings. + (get-accum-reduced [memory node join-bindings fact-bindings]) + + ;; Returns all reduced results for the given node that matches + ;; the given join bindings, independent of the individual fact-bindings + ;; created by the accumulator's condition. + (get-accum-reduced-all [memory node join-bindings]) + + ;; Returns a tuple of [join-bindings fact-bindings result] for all + ;; accumulated items on this node. + (get-accum-reduced-complete [memory node]) + + ;; Returns insertions that occurred at the given node for the given token. + ;; Returns a sequence of the form + ;; [facts-inserted-for-one-rule-activation facts-inserted-for-another-rule-activation] + (get-insertions [memory node token]) + + ;; Returns all insertions that occurred in the given node's RHS; this takes the form + ;; {token [facts-inserted-for-one-rule-activation facts-inserted-for-another-rule-activation]} + (get-insertions-all [memory node]) + + ;; Returns a map of nodes with pending activations to the activations themselves. + (get-activations [memory])) + +(defprotocol ITransientMemory + + ;; Adds working memory elements to the given working memory at the given node. + (add-elements! [memory node join-bindings elements]) + + ;; Remove working memory elements from the given working memory at the given node. + (remove-elements! [memory node elements join-bindings]) + + ;; Add tokens to the given working memory at the given node. + (add-tokens! [memory node join-bindings tokens]) + + ;; Removes tokens from the given working memory at the given node. + (remove-tokens! [memory node join-bindings tokens]) + + ;; Adds the result of a reduced accumulator execution to the given memory and node. + (add-accum-reduced! [memory node join-bindings accum-result fact-bindings]) + + ;; Removes the result of a reduced accumulator execution to the given memory and node. + (remove-accum-reduced! [memory node join-bindings fact-bindings]) + + ;; Add a record that a given fact twas inserted at a given node with + ;; the given support. Used for truth maintenance. + ;; This should be called at most once per rule activation. + (add-insertions! [memory node token facts]) + + ;; Removes all records of facts that were inserted at the given node + ;; due to the given token. Used for truth maintenance. + ;; This function returns a map of each token to the associated facts + ;; it removed. + (remove-insertions! [memory node token]) + + ;; Add a sequence of activations. + (add-activations! [memory production activations]) + + ;; Pop an activation from the working memory. Returns nil if no + ;; activations are pending. + (pop-activations! [memory count]) + + ;; Returns the group of the next activation, or nil if none are pending. + (next-activation-group [memory]) + + ;; Remove the given activations from the working memory. This is expected + ;; to return a tuple of the form [removed-activations unremoved-activations], + ;; where unremoved-activations is comprised of activations passed to the memory + ;; for removal but which were not removed because they were not present in the memory's + ;; store of pending activations. + (remove-activations! [memory production activations]) + + ;; Clear all activations from the working memory + (clear-activations! [memory]) + + ;; Converts the transient memory to persistent form. + (to-persistent! [memory])) + +(defn- coll-empty? + "Returns true if the collection is empty. Does not call seq due to avoid + overhead that may cause for non-persistent collection types, e.g. + java.util.LinkedList, etc." + [^java.util.Collection coll] + (or (nil? coll) (.isEmpty coll))) + +(defn- list-remove! + "Removes the item, to-remove, from the given list, lst. If it is found and removed, + returns true. Otherwise returns false. Only removes the first element in the list + that is equal to to-remove. Equality is done based on the given eq-pred function. + If it isn't given, the default is = . If others are equal, they will not be removed. + This is similar to java.util.List.remove(Object). lst is updated in place for performance. + This implies that the list must support the mutable list interface, namely via the + java.util.List.listIterator()." + ([^java.util.List lst to-remove] + (list-remove! lst to-remove =)) + ([^java.util.List lst to-remove eq-pred] + (if-not (coll-empty? lst) + (let [li (.listIterator lst)] + (loop [x (.next li)] + (cond + (eq-pred to-remove x) + (do + (.remove li) + true) + + (.hasNext li) + (recur (.next li)) + + :else + false))) + false))) + +(defn- add-all! + "Adds all items from source to the destination dest collection + destructively. Avoids using Collection.addAll() due to unnecessary + performance overhead of calling Collection.toArray() on the + incoming source. Returns dest." + [^java.util.Collection dest source] + (doseq [x source] + (.add dest x)) + dest) + +(defn- linked-list? + [coll] + (instance? LinkedList coll)) + +(defn- ->linked-list + "Creates a new java.util.LinkedList from the coll, but avoids using + Collection.addAll(Collection) since there is unnecessary overhead + in this of calling Collection.toArray() on coll." + ^java.util.List [coll] + (if (linked-list? coll) + coll + (add-all! (LinkedList.) coll))) + +(defn- mutable-map? + [m] + (instance? MutableMap m)) + +(defn- ->mutable-map + "Creates a new ham_fisted.MutableMap from the map, but only if necessary." + [m] + (if (mutable-map? m) + m + (hf/mut-map m))) + +(defn- ->persistent-coll + "Creates a persistent collection from the input collection, but only if necessary" + [coll] + (cond + (coll? coll) + coll + + (mutable-map? coll) + (persistent! coll) + + (map? coll) + (persistent! coll) + + :else + (seq coll))) + +(defn- remove-first-of-each! + "Remove the first instance of each item in the given remove-seq that + appears in the collection coll. coll is updated in place for + performance. This implies that the coll must support the mutable + collection interface method Collection.remove(Object). Returns a tuple + of the form [remove-seq-items-removed remove-seq-items-not-removed]. + An optional compare-fn can be given to specify how to compare remove-seq + items against items in coll. The default compare-fn is = . + For immutable collection removal, use the non-destructive remove-first-of-each + defined below." + ([remove-seq ^java.util.List coll] + (remove-first-of-each! remove-seq coll =)) + + ([remove-seq ^java.util.List coll compare-fn] + ;; Optimization for special case of one item to remove, + ;; which occurs frequently. + (if (= 1 (count remove-seq)) + (let [to-remove (first remove-seq)] + (if (list-remove! coll to-remove compare-fn) + [remove-seq []] + [[] remove-seq])) + + ;; Otherwise, perform a linear search for items to remove. + (loop [to-remove (first remove-seq) + remove-seq (next remove-seq) + removed (transient []) + not-removed (transient [])] + (if to-remove + (let [found? (list-remove! coll to-remove compare-fn) + removed (if found? + (conj! removed to-remove) + removed) + not-removed (if found? + not-removed + (conj! not-removed to-remove))] + (recur (first remove-seq) + (next remove-seq) + removed + not-removed)) + ;; If this is expensive, using a mutable collection maybe good to + ;; consider here in a future optimization. + [(persistent! removed) (persistent! not-removed)]))))) + +(defn remove-first-of-each + "Remove the first instance of each item in the given remove-seq that + appears in the collection. This also tracks which items were found + and removed. Returns a tuple of the form: + [items-removed coll-with-items-removed items-not-removed] + This function does so eagerly since + the working memories with large numbers of insertions and retractions + can cause lazy sequences to become deeply nested." + [remove-seq coll] + (cond + + ;; There is nothing to remove. + (empty? remove-seq) [[] coll] + + ;; Otherwise, perform a linear search for items to remove. + :else (loop [f (first coll) + r (rest coll) + [remove-seq items-removed result] [remove-seq (transient []) (transient [])]] + + (if f + (recur (first r) + (rest r) + + ;; Determine if f matches any of the items to remove. + (loop [to-remove (first remove-seq) + remove-seq (rest remove-seq) + ;; Remember what is left to remove for later. + left-to-remove (transient [])] + + ;; Try to find if f matches anything to-remove. + (if to-remove + (if (= to-remove f) + + ;; Found a match, so the search is done. + [(persistent! (reduce conj! left-to-remove remove-seq)) + (conj! items-removed to-remove) + result] + + ;; Keep searching for a match. + (recur (first remove-seq) + (rest remove-seq) + (conj! left-to-remove to-remove))) + + ;; No matches found. + [(persistent! left-to-remove) + items-removed + (conj! result f)]))) + + [(persistent! items-removed) (persistent! result) remove-seq])))) + +(defn fast-token-compare [compare-fn token other-token] + ;; Fastest path is if the two tokens are truly identical. + (or (identical? token other-token) + ;; Assumption is that both arguments given are tokens already. + (and (let [bindings (:bindings token) + other-bindings (:bindings other-token)] + ;; Calling `count` on these Clojure maps shows up as a bottleneck + ;; even with clojure.lang.IPersistentMap being clojure.lang.Counted unfortunately. + (and (= (.size ^java.util.Map bindings) + (.size ^java.util.Map other-bindings)) + ;; `every?` is too slow for a performance critical place like this. It + ;; calls `seq` too many times on the underlying maps. Instead `seq` one + ;; time and keep using that same seq. + ;; Also avoiding Clojure destructuring since even that is not as fast + ;; pre-1.9.0. + (if-let [^clojure.lang.ISeq entries (.seq ^clojure.lang.Seqable bindings)] + ;; Type hint to Indexed vs MapEntry just because MapEntry seems to be a + ;; less stable impl detail to rely on. + (loop [^clojure.lang.Indexed entry (.first entries) + entries (.next entries)] + (let [k (some-> entry (.nth 0)) + v (some-> entry (.nth 1))] + (if (and k + ;; other-bindings will always be persistent map so invoke + ;; it directly. It is faster than `get`. + (compare-fn v (other-bindings k))) + (recur (some-> entries .first) + (some-> entries .next)) + ;; If there is no k left, then every entry matched. If there is a k, + ;; that means the comparison failed, so the maps aren't equal. + (not k)))) + ;; Empty bindings on both sides. + true))) + + ;; Check the :matches on each token. :matches need to be in the same order on both + ;; tokens to be considered the same. + (let [^clojure.lang.Indexed matches (:matches token) + ^clojure.lang.Indexed other-matches (:matches other-token) + count-matches (.size ^java.util.List matches)] + (and (= count-matches + (.size ^java.util.List other-matches)) + (loop [i 0] + (cond + (= i count-matches) + true + + ;; Compare node-id's first. Fallback to comparing facts. This will + ;; most very likely be the most expensive part to execute. + (let [^clojure.lang.Indexed m (.nth matches i) + ^clojure.lang.Indexed om (.nth other-matches i)] + ;; A token :matches tuple is of the form [fact node-id]. + (and (= (.nth m 1) (.nth om 1)) + (compare-fn (.nth m 0) (.nth om 0)))) + (recur (inc i)) + + :else + false))))))) + +(defprotocol IdentityComparable + (using-token-identity! [this bool])) + +(deftype RuleOrderedActivation [node-id + token + activation + rule-load-order + ^:unsynchronized-mutable use-token-identity?] + IdentityComparable + ;; NOTE! This should never be called on a RuleOrderedActivation instance that has been stored + ;; somewhere in local memory because it could cause interference across threads that have + ;; multiple versions of local memories that are sharing some of their state. This is only intended + ;; to be called by ephemeral, only-local references to RuleOrderedActivation instances used to + ;; search for activations to remove from memory when performing `remove-activations!` operations. + ;; The reason this mutable state exists at all is to "flip" a single instance of a RuleOrderedActivation + ;; from identity to value equality based comparable when doing the "two-pass" removal search operation + ;; of `remove-activations!`. This avoids having to create different instances for each pass. + (using-token-identity! [this bool] + (set! use-token-identity? bool) + this) + Object + ;; Two RuleOrderedActivation instances should be equal if and only if their + ;; activation is equal. Note that if the node of two activations is the same, + ;; their rule-load-order must be the same. Using a deftype wrapper allows us to + ;; use Clojure equality to determine this while placing the wrapper in a Java data + ;; structure that uses Java equality; the Java equality check will simply end up calling + ;; Clojure equality checks. + (equals [this other] + ;; Note that the .equals method is only called by PriorityQueue.remove, and the object provided + ;; to the .remove method will never be identical to any object in the queue. A short-circuiting + ;; check for reference equality would therefore be pointless here because it would never be true. + (boolean + (when (instance? RuleOrderedActivation other) + (let [^RuleOrderedActivation other other] + (and + ;; If the node-id of two nodes is equal then we can assume that the nodes are equal. + (= node-id + (.node-id other)) + + ;; We check with identity based semantics on the other when the use-token-identity? field + ;; indicates to do so. + (if (or use-token-identity? (.-use-token-identity? other)) + (fast-token-compare identical? token (.-token other)) + (fast-token-compare = token (.-token other))))))))) + +(defn- ->rule-ordered-activation + "Take an activation from the engine and wrap it in a map that includes information + on the rule load order. In Clojure, as opposed to ClojureScript, each activation should + be wrapped in this way exactly once (that is, the value of the :activation key should + be an activation from the engine.)" + ([activation] + (->rule-ordered-activation activation false)) + ([activation use-token-identity?] + (let [node (:node activation)] + (RuleOrderedActivation. (:id node) + (:token activation) + activation + (or (-> node + :production + meta + :clara.rules.compiler/rule-load-order) + 0) + use-token-identity?)))) + +(defn- queue-activations! + "Add activations to a queue. The wrap-rule-order? option should be true + unless the activations in question have previously been wrapped." + ([^java.util.Queue pq activations] + (queue-activations! pq activations true)) + ([^java.util.Queue pq activations wrap-rule-order?] + (if wrap-rule-order? + (doseq [act activations] + (.add pq (->rule-ordered-activation act))) + (doseq [act activations] + (.add pq act))) + pq)) + +(defn- ->activation-priority-queue + "Given activations, create a priority queue based on rule ordering. + The activations should be wrapped by using the wrap-rule-order? option + if they have not been wrapped already." + ([activations] + (->activation-priority-queue activations true)) + ([activations wrap-rule-order?] + (let [init-cnt (count activations) + ;; Note that 11 is the default initial value; there is no constructor + ;; for PriorityQueue that takes a custom comparator and does not require + ;; an initial size to be passed. + pq (PriorityQueue. (if (pos? init-cnt) init-cnt 11) + (fn [^RuleOrderedActivation x + ^RuleOrderedActivation y] + (compare (.rule-load-order x) + (.rule-load-order y))))] + (queue-activations! pq activations wrap-rule-order?)))) + +(declare ->PersistentLocalMemory) + +;;; Transient local memory implementation. Typically only persistent memory will be visible externally. + +(deftype TransientLocalMemory [rulebase + activation-group-sort-fn + activation-group-fn + alphas-fn + ^Map alpha-memory + ^Map beta-memory + ^Map accum-memory + ^Map production-memory + ^NavigableMap activation-map] + + IMemoryReader + (get-rulebase [memory] rulebase) + + (get-alphas-fn [memory] alphas-fn) + + (get-elements [memory node bindings] + (get (get alpha-memory (:id node) {}) + bindings + [])) + + (get-elements-all [memory node] + (sequence + cat + (vals + (get alpha-memory (:id node) {})))) + + (get-tokens [memory node bindings] + (get (get beta-memory (:id node) {}) + bindings + [])) + + (get-tokens-all [memory node] + (sequence + cat + (vals (get beta-memory (:id node) {})))) + + (get-accum-reduced [memory node join-bindings fact-bindings] + (get-in accum-memory [(:id node) join-bindings fact-bindings] ::no-accum-reduced)) + + (get-accum-reduced-all [memory node join-bindings] + (get + (get accum-memory (:id node) {}) + join-bindings)) + + ;; TODO: rename existing get-accum-reduced-all and use something better here. + (get-accum-reduced-complete [memory node] + (for [[join-binding joins] (get accum-memory (:id node) {}) + [fact-binding reduced] joins] + {:join-bindings join-binding + :fact-bindings fact-binding + :result reduced})) + + (get-insertions [memory node token] + (get + (get production-memory (:id node) {}) + token + [])) + + (get-insertions-all [memory node] + (get production-memory (:id node) {})) + + (get-activations [memory] + (into [] + (comp cat + (map (fn [^RuleOrderedActivation a] + (.activation a)))) + (vals activation-map))) + + ITransientMemory + (add-elements! [memory node join-bindings elements] + (hm/compute! alpha-memory (:id node) + (fn do-add-bem + [_ bem] + (if bem + (let [binding-element-map (->mutable-map bem)] + (hm/compute! binding-element-map join-bindings + (fn do-add-bel + [_ bel] + (if bel + (let [binding-element-list (->linked-list bel)] + (add-all! binding-element-list elements) + binding-element-list) + elements))) + binding-element-map) + {join-bindings elements})))) + + (remove-elements! [memory node join-bindings elements] + ;; Do nothing when no elements to remove. + (when-not (coll-empty? elements) + (let [removed-elements-result (hf/mut-list)] + (hm/compute-if-present! alpha-memory (:id node) + (fn do-rem-bem + [_ bem] + (let [binding-element-map (->mutable-map bem)] + (hm/compute-if-present! binding-element-map join-bindings + (fn do-rem-bel + [_ bel] + (let [binding-element-list (->linked-list bel) + removed-elements (first (remove-first-of-each! elements binding-element-list))] + (hf/add-all! removed-elements-result removed-elements) + (not-empty binding-element-list)))) + (not-empty binding-element-map)))) + (hf/persistent! removed-elements-result)))) + + (add-tokens! [memory node join-bindings tokens] + (hm/compute! beta-memory (:id node) + (fn do-add-btm + [_ btm] + (if btm + (let [binding-token-map (->mutable-map btm)] + (hm/compute! binding-token-map join-bindings + (fn do-add-btl + [_ btl] + (if btl + (let [binding-token-list (->linked-list btl)] + (add-all! binding-token-list tokens) + binding-token-list) + tokens))) + binding-token-map) + {join-bindings tokens})))) + + (remove-tokens! [memory node join-bindings tokens] + ;; The reasoning here is the same as remove-elements! + (when-not (coll-empty? tokens) + (let [removed-tokens-result (hf/mut-list)] + (hm/compute-if-present! + beta-memory (:id node) + (fn do-rem-btm + [_ btm] + (let [binding-token-map (->mutable-map btm)] + (hm/compute-if-present! + binding-token-map join-bindings + (fn do-rem-btl + [_ btl] + (let [binding-token-list (->linked-list btl) + ;; Attempt to remove tokens using the faster indentity-based equality first since + ;; most of the time this is all we need and it can be much faster. Any token that + ;; wasn't removed via identity, has to be "retried" with normal value-based + ;; equality though since those semantics are supported within the engine. This + ;; slower path should be rare for any heavy retraction flows - such as those that come + ;; via truth maintenance. + [removed-tokens not-removed-tokens] + (remove-first-of-each! tokens + binding-token-list + (partial fast-token-compare identical?))] + (hf/add-all! removed-tokens-result removed-tokens) + (when (seq not-removed-tokens) + (let [[other-removed-tokens] + (remove-first-of-each! not-removed-tokens binding-token-list + (partial fast-token-compare =))] + (hf/add-all! removed-tokens-result other-removed-tokens))) + (not-empty binding-token-list)))) + (not-empty binding-token-map)))) + (hf/persistent! removed-tokens-result)))) + + (add-accum-reduced! [memory node join-bindings accum-result fact-bindings] + (hm/compute! accum-memory (:id node) + (fn add-jbam + [_ jbam] + (if jbam + (let [join-binding-accum-map (->mutable-map jbam)] + (hm/compute! join-binding-accum-map join-bindings + (fn add-fbam + [_ fact-binding-accum-map] + (assoc fact-binding-accum-map fact-bindings accum-result))) + join-binding-accum-map) + {join-bindings {fact-bindings accum-result}})))) + + (remove-accum-reduced! [memory node join-bindings fact-bindings] + (hm/compute-if-present! accum-memory (:id node) + (fn add-jbam + [_ jbam] + (let [join-binding-accum-map (->mutable-map jbam)] + (hm/compute-if-present! join-binding-accum-map join-bindings + (fn add-fbam + [_ fact-binding-accum-map] + (not-empty (dissoc fact-binding-accum-map fact-bindings)))) + (not-empty join-binding-accum-map))))) + + ;; The value under each token in the map should be a sequence + ;; of sequences of facts, with each inner sequence coming from a single + ;; rule activation. + (add-insertions! [memory node token facts] + (hm/compute! production-memory (:id node) + (fn add-tfm + [_ tfm] + (if tfm + (let [token-facts-map (->mutable-map tfm)] + (hm/compute! token-facts-map token + (fn add-tfl + [_ tfl] + (let [^List token-facts-list (->linked-list tfl)] + (.add token-facts-list facts) + token-facts-list))) + token-facts-map) + {token [facts]})))) + + (remove-insertions! [memory node tokens] + ;; Remove the facts inserted from the given token. + (let [results (hf/mut-map)] + (hm/compute-if-present! production-memory (:id node) + (fn rem-tfm + [_ tfm] + (let [token-facts-map (->mutable-map tfm)] + (doseq [token tokens] + (hm/compute-if-present! token-facts-map token + (fn [_ tfl] + ;; Don't use contains? due to http://dev.clojure.org/jira/browse/CLJ-700 + (let [^List token-facts-list (->linked-list tfl) + ;; There is no particular significance in removing the + ;; first group; we just need to remove exactly one. + removed-facts (.remove token-facts-list 0)] + (hm/compute! results token + (fn add-tfr + [_ tfr] + (let [token-facts-removed (->linked-list tfr)] + (add-all! token-facts-removed removed-facts) + token-facts-removed))) + (not-empty token-facts-list))))) + (not-empty token-facts-map)))) + (persistent! (hf/update-values results (fn to-persistent [_ coll] + (->persistent-coll coll)))))) + + (add-activations! + [memory production new-activations] + (let [activation-group (activation-group-fn production)] + (hm/compute! activation-map activation-group + (fn do-add-activations + [_ old-activations] + (cond + old-activations + (queue-activations! old-activations new-activations) + + (not (coll-empty? new-activations)) + (->activation-priority-queue new-activations) + + :else nil))))) + + (pop-activations! + [memory count] + (loop [^List activations (hf/mut-list) + remaining count] + (cond + (.isEmpty activation-map) + (persistent! activations) + + (not (and (number? remaining) + (pos? remaining))) + (persistent! activations) + + :else + (let [entry (.firstEntry activation-map) + key (.getKey entry) + ^java.util.Queue activation-queue (.getValue entry) + curr-popped-activations (not (.isEmpty activations)) + next-no-loop-activation (some-> ^RuleOrderedActivation (.peek activation-queue) + (.activation) + :node :production :props :no-loop)] + (if (and curr-popped-activations next-no-loop-activation) + (persistent! activations) + (let [;; An empty value is illegal and should be removed by an action + ;; that creates one (e.g. a remove-activations! call). + ^RuleOrderedActivation activation-wrapper (.remove activation-queue) + ;; Extract the selected activation. + activation (.activation activation-wrapper) + empty-activation-group (.isEmpty activation-queue)] + (.add activations activation) + ;; This activation group is empty now, so remove it from + ;; the map entirely. + (when empty-activation-group + (.remove activation-map key)) + (cond + ;; This activation group is empty so return and do not move + ;; to the next activation group + empty-activation-group + (persistent! activations) + ;; When we encounter a no-loop activation we need to stop returning activations since it would + ;; flush updates after the RHS is activated + (some-> activation :node :production :props :no-loop) + (persistent! activations) + + :else + (recur activations (dec remaining))))))))) + + (next-activation-group + [memory] + (when (not (.isEmpty activation-map)) + (let [entry (.firstEntry activation-map)] + (.getKey entry)))) + + (remove-activations! [memory production to-remove] + (when-not (coll-empty? to-remove) + (let [activation-group (activation-group-fn production) + ^java.util.Queue activations (.get activation-map activation-group) + removed-activations (LinkedList.) + unremoved-activations (LinkedList.)] + + (if (coll-empty? activations) + ;; If there are no activations present under the group + ;; then we can't remove any. + [[] to-remove] + ;; Remove as many activations by identity as possible first. + (let [not-removed (loop [to-remove-item (first to-remove) + to-remove (next to-remove) + not-removed (transient [])] + (if to-remove-item + (let [^RuleOrderedActivation act (->rule-ordered-activation to-remove-item true)] + (if (.remove activations act) + (do + (.add removed-activations (.activation act)) + ;; The activations that are not removed in the identity checking sweep + ;; are a superset of the activations that are removed after the equality + ;; sweep finishes so we can just create the list of unremoved activations + ;; during that sweep. + (recur (first to-remove) (next to-remove) not-removed)) + (recur (first to-remove) (next to-remove) (conj! not-removed act)))) + (persistent! not-removed)))] + + ;; There may still be activations not removed since the removal may be based on value-based + ;; equality semantics. Retractions in the engine do not require that identical object references + ;; are given to remove object values that are equal. + (doseq [^RuleOrderedActivation act not-removed] + (if (.remove activations (using-token-identity! act false)) + (.add removed-activations (.activation act)) + (.add unremoved-activations (.activation act)))) + + (when (coll-empty? activations) + (.remove activation-map activation-group)) + + [(Collections/unmodifiableList removed-activations) + (Collections/unmodifiableList unremoved-activations)]))))) + + (clear-activations! + [memory] + (.clear activation-map)) + + (to-persistent! [memory] + (let [persistent-maps (fn do-update-vals [update-fn m] + (->> m + (reduce-kv (fn [m k v] + (assoc! m k (update-fn v))) + (hf/mut-map)) + persistent!)) + persistent-vals (partial persistent-maps ->persistent-coll)] + (->PersistentLocalMemory rulebase + activation-group-sort-fn + activation-group-fn + alphas-fn + (persistent-maps persistent-vals alpha-memory) + (persistent-maps persistent-vals beta-memory) + (persistent-maps persistent-vals accum-memory) + (persistent-maps persistent-vals production-memory) + (into {} + (map (juxt key (comp ->persistent-coll val))) + activation-map))))) + +(defrecord PersistentLocalMemory [rulebase + activation-group-sort-fn + activation-group-fn + alphas-fn + alpha-memory + beta-memory + accum-memory + production-memory + activation-map] + IMemoryReader + (get-rulebase [memory] rulebase) + + (get-alphas-fn [memory] alphas-fn) + + (get-elements [memory node bindings] + (get (get alpha-memory (:id node) {}) + bindings + [])) + + (get-elements-all [memory node] + (sequence + cat + (vals + (get alpha-memory (:id node) {})))) + + (get-tokens [memory node bindings] + (get (get beta-memory (:id node) {}) + bindings + [])) + + (get-tokens-all [memory node] + (sequence + cat + (vals (get beta-memory (:id node) {})))) + + (get-accum-reduced [memory node join-bindings fact-bindings] + ;; nil is a valid previously reduced value that can be found in the map. + ;; Return ::no-accum-reduced instead of nil when there is no previously + ;; reduced value in memory. + (get-in accum-memory [(:id node) join-bindings fact-bindings] ::no-accum-reduced)) + + (get-accum-reduced-all [memory node join-bindings] + (get + (get accum-memory (:id node) {}) + join-bindings)) + + (get-accum-reduced-complete [memory node] + (for [[join-binding joins] (get accum-memory (:id node) {}) + [fact-binding reduced] joins] + {:join-bindings join-binding + :fact-bindings fact-binding + :result reduced})) + + (get-insertions [memory node token] + (get + (get production-memory (:id node) {}) + token + [])) + + (get-insertions-all [memory node] + (get production-memory (:id node) {})) + + (get-activations [memory] + (into [] + (comp cat + (map (fn [^RuleOrderedActivation a] + (.activation a)))) + (vals activation-map))) + + IPersistentMemory + (to-transient [memory] + (TransientLocalMemory. rulebase + activation-group-sort-fn + activation-group-fn + alphas-fn + (->mutable-map alpha-memory) + (->mutable-map beta-memory) + (->mutable-map accum-memory) + (->mutable-map production-memory) + (let [treemap (TreeMap. ^java.util.Comparator activation-group-sort-fn)] + (doseq [[activation-group activations] activation-map] + (.put treemap + activation-group + (->activation-priority-queue activations false))) + treemap)))) + +(defn local-memory + "Creates an persistent local memory for the given rule base." + [rulebase activation-group-sort-fn activation-group-fn alphas-fn] + + (->PersistentLocalMemory rulebase + activation-group-sort-fn + activation-group-fn + alphas-fn + (hf/hash-map) + (hf/hash-map) + (hf/hash-map) + (hf/hash-map) + (hf/hash-map))) diff --git a/src/main/clojure/clara/rules/memory.cljc b/src/main/clojure/clara/rules/memory.cljc deleted file mode 100644 index dd72c998..00000000 --- a/src/main/clojure/clara/rules/memory.cljc +++ /dev/null @@ -1,1068 +0,0 @@ -(ns clara.rules.memory - "This namespace is for internal use and may move in the future. - Specification and default implementation of working memory" - (:require [clojure.set :as s])) - -;; Activation record used by get-activations and add-activations! below. -(defrecord Activation [node token]) - -(defprotocol IPersistentMemory - (to-transient [memory])) - -(defprotocol IMemoryReader - ;; Returns the rulebase associated with the given memory. - (get-rulebase [memory]) - - ;; Returns a function that produces a map of alpha nodes to - ;; facts that match the type of the node - (get-alphas-fn [memory]) - - ;; Returns the elements assoicated with the given node. - (get-elements [memory node bindings]) - - ;; Returns all elements associated with the given node, regardless of bindings. - (get-elements-all [memory node]) - - ;; Returns the tokens associated with the given node. - (get-tokens [memory node bindings]) - - ;; Returns all tokens associated with the given node, regardless of bindings - (get-tokens-all [memory node]) - - ;; Returns the reduced form of objects processed by an accumulator node - ;; for facts that match the given bindings. - (get-accum-reduced [memory node join-bindings fact-bindings]) - - ;; Returns all reduced results for the given node that matches - ;; the given join bindings, independent of the individual fact-bindings - ;; created by the accumulator's condition. - (get-accum-reduced-all [memory node join-bindings]) - - ;; Returns a tuple of [join-bindings fact-bindings result] for all - ;; accumulated items on this node. - (get-accum-reduced-complete [memory node]) - - ;; Returns insertions that occurred at the given node for the given token. - ;; Returns a sequence of the form - ;; [facts-inserted-for-one-rule-activation facts-inserted-for-another-rule-activation] - (get-insertions [memory node token]) - - ;; Returns all insertions that occurred in the given node's RHS; this takes the form - ;; {token [facts-inserted-for-one-rule-activation facts-inserted-for-another-rule-activation]} - (get-insertions-all [memory node]) - - ;; Returns a map of nodes with pending activations to the activations themselves. - (get-activations [memory])) - -(defprotocol ITransientMemory - - ;; Adds working memory elements to the given working memory at the given node. - (add-elements! [memory node join-bindings elements]) - - ;; Remove working memory elements from the given working memory at the given node. - (remove-elements! [memory node elements join-bindings]) - - ;; Add tokens to the given working memory at the given node. - (add-tokens! [memory node join-bindings tokens]) - - ;; Removes tokens from the given working memory at the given node. - (remove-tokens! [memory node join-bindings tokens]) - - ;; Adds the result of a reduced accumulator execution to the given memory and node. - (add-accum-reduced! [memory node join-bindings accum-result fact-bindings]) - - ;; Removes the result of a reduced accumulator execution to the given memory and node. - (remove-accum-reduced! [memory node join-bindings fact-bindings]) - - ;; Add a record that a given fact twas inserted at a given node with - ;; the given support. Used for truth maintenance. - ;; This should be called at most once per rule activation. - (add-insertions! [memory node token facts]) - - ;; Removes all records of facts that were inserted at the given node - ;; due to the given token. Used for truth maintenance. - ;; This function returns a map of each token to the associated facts - ;; it removed. - (remove-insertions! [memory node token]) - - ;; Add a sequence of activations. - (add-activations! [memory production activations]) - - ;; Pop an activation from the working memory. Returns nil if no - ;; activations are pending. - (pop-activation! [memory]) - - ;; Returns the group of the next activation, or nil if none are pending. - (next-activation-group [memory]) - - ;; Remove the given activations from the working memory. This is expected - ;; to return a tuple of the form [removed-activations unremoved-activations], - ;; where unremoved-activations is comprised of activations passed to the memory - ;; for removal but which were not removed because they were not present in the memory's - ;; store of pending activations. - (remove-activations! [memory production activations]) - - ;; Clear all activations from the working memory - (clear-activations! [memory]) - - ;; Converts the transient memory to persistent form. - (to-persistent! [memory])) - -#?(:clj - (defn- coll-empty? - "Returns true if the collection is empty. Does not call seq due to avoid - overhead that may cause for non-persistent collection types, e.g. - java.util.LinkedList, etc." - [^java.util.Collection coll] - (or (nil? coll) (.isEmpty coll)))) - -#?(:clj - (defn- list-remove! - "Removes the item, to-remove, from the given list, lst. If it is found and removed, - returns true. Otherwise returns false. Only removes the first element in the list - that is equal to to-remove. Equality is done based on the given eq-pred function. - If it isn't given, the default is = . If others are equal, they will not be removed. - This is similar to java.util.List.remove(Object). lst is updated in place for performance. - This implies that the list must support the mutable list interface, namely via the - java.util.List.listIterator()." - ([^java.util.List lst to-remove] - (list-remove! lst to-remove =)) - ([^java.util.List lst to-remove eq-pred] - (if-not (coll-empty? lst) - (let [li (.listIterator lst)] - (loop [x (.next li)] - (cond - (eq-pred to-remove x) - (do - (.remove li) - true) - - (.hasNext li) - (recur (.next li)) - - :else - false))) - false)))) - -#?(:clj - (defn- add-all! - "Adds all items from source to the destination dest collection - destructively. Avoids using Collection.addAll() due to unnecessary - performance overhead of calling Collection.toArray() on the - incoming source. Returns dest." - [^java.util.Collection dest source] - (doseq [x source] - (.add dest x)) - dest)) - -#?(:clj - (defn- ^java.util.List ->linked-list - "Creates a new java.util.LinkedList from the coll, but avoids using - Collection.addAll(Collection) since there is unnecessary overhead - in this of calling Collection.toArray() on coll." - [coll] - (if (instance? java.util.LinkedList coll) - coll - (add-all! (java.util.LinkedList.) coll)))) - -#?(:clj - (defn- remove-first-of-each! - "Remove the first instance of each item in the given remove-seq that - appears in the collection coll. coll is updated in place for - performance. This implies that the coll must support the mutable - collection interface method Collection.remove(Object). Returns a tuple - of the form [remove-seq-items-removed remove-seq-items-not-removed]. - An optional compare-fn can be given to specify how to compare remove-seq - items against items in coll. The default compare-fn is = . - For immutable collection removal, use the non-destructive remove-first-of-each - defined below." - ([remove-seq ^java.util.List coll] - (remove-first-of-each! remove-seq coll =)) - - ([remove-seq ^java.util.List coll compare-fn] - ;; Optimization for special case of one item to remove, - ;; which occurs frequently. - (if (= 1 (count remove-seq)) - (let [to-remove (first remove-seq)] - (if (list-remove! coll to-remove compare-fn) - [remove-seq []] - [[] remove-seq])) - - ;; Otherwise, perform a linear search for items to remove. - (loop [to-remove (first remove-seq) - remove-seq (next remove-seq) - removed (transient []) - not-removed (transient [])] - (if to-remove - (let [found? (list-remove! coll to-remove compare-fn) - removed (if found? - (conj! removed to-remove) - removed) - not-removed (if found? - not-removed - (conj! not-removed to-remove))] - (recur (first remove-seq) - (next remove-seq) - removed - not-removed)) - ;; If this is expensive, using a mutable collection maybe good to - ;; consider here in a future optimization. - [(persistent! removed) (persistent! not-removed)])))))) - -(defn remove-first-of-each - "Remove the first instance of each item in the given remove-seq that - appears in the collection. This also tracks which items were found - and removed. Returns a tuple of the form: - [items-removed coll-with-items-removed items-not-removed] - This function does so eagerly since - the working memories with large numbers of insertions and retractions - can cause lazy sequences to become deeply nested." - [remove-seq coll] - (cond - - ;; There is nothing to remove. - (empty? remove-seq) [[] coll] - - ;; Otherwise, perform a linear search for items to remove. - :else (loop [f (first coll) - r (rest coll) - [remove-seq items-removed result] [remove-seq (transient []) (transient [])]] - - (if f - (recur (first r) - (rest r) - - ;; Determine if f matches any of the items to remove. - (loop [to-remove (first remove-seq) - remove-seq (rest remove-seq) - ;; Remember what is left to remove for later. - left-to-remove (transient [])] - - ;; Try to find if f matches anything to-remove. - (if to-remove - (if (= to-remove f) - - ;; Found a match, so the search is done. - [(persistent! (reduce conj! left-to-remove remove-seq)) - (conj! items-removed to-remove) - result] - - ;; Keep searching for a match. - (recur (first remove-seq) - (rest remove-seq) - (conj! left-to-remove to-remove))) - - ;; No matches found. - [(persistent! left-to-remove) - items-removed - (conj! result f)]))) - - [(persistent! items-removed) (persistent! result) remove-seq])))) - -#?(:clj - (defn fast-token-compare [compare-fn token other-token] - ;; Fastest path is if the two tokens are truly identical. - (or (identical? token other-token) - ;; Assumption is that both arguments given are tokens already. - (and (let [bindings (:bindings token) - other-bindings (:bindings other-token)] - ;; Calling `count` on these Clojure maps shows up as a bottleneck - ;; even with clojure.lang.IPersistentMap being clojure.lang.Counted unfortunately. - (and (= (.size ^java.util.Map bindings) - (.size ^java.util.Map other-bindings)) - ;; `every?` is too slow for a performance critical place like this. It - ;; calls `seq` too many times on the underlying maps. Instead `seq` one - ;; time and keep using that same seq. - ;; Also avoiding Clojure destructuring since even that is not as fast - ;; pre-1.9.0. - (if-let [^clojure.lang.ISeq entries (.seq ^clojure.lang.Seqable bindings)] - ;; Type hint to Indexed vs MapEntry just because MapEntry seems to be a - ;; less stable impl detail to rely on. - (loop [^clojure.lang.Indexed entry (.first entries) - entries (.next entries)] - (let [k (some-> entry (.nth 0)) - v (some-> entry (.nth 1))] - (if (and k - ;; other-bindings will always be persistent map so invoke - ;; it directly. It is faster than `get`. - (compare-fn v (other-bindings k))) - (recur (some-> entries .first) - (some-> entries .next)) - ;; If there is no k left, then every entry matched. If there is a k, - ;; that means the comparison failed, so the maps aren't equal. - (not k)))) - ;; Empty bindings on both sides. - true))) - - ;; Check the :matches on each token. :matches need to be in the same order on both - ;; tokens to be considered the same. - (let [^clojure.lang.Indexed matches (:matches token) - ^clojure.lang.Indexed other-matches (:matches other-token) - count-matches (.size ^java.util.List matches)] - (and (= count-matches - (.size ^java.util.List other-matches)) - (loop [i 0] - (cond - (= i count-matches) - true - - ;; Compare node-id's first. Fallback to comparing facts. This will - ;; most very likely be the most expensive part to execute. - (let [^clojure.lang.Indexed m (.nth matches i) - ^clojure.lang.Indexed om (.nth other-matches i)] - ;; A token :matches tuple is of the form [fact node-id]. - (and (= (.nth m 1) (.nth om 1)) - (compare-fn (.nth m 0) (.nth om 0)))) - (recur (inc i)) - - :else - false)))))))) - -#?(:clj - (defprotocol IdentityComparable - (using-token-identity! [this bool]))) - -#?(:clj - (deftype RuleOrderedActivation [node-id - token - activation - rule-load-order - ^:unsynchronized-mutable use-token-identity?] - IdentityComparable - ;; NOTE! This should never be called on a RuleOrderedActivation instance that has been stored - ;; somewhere in local memory because it could cause interference across threads that have - ;; multiple versions of local memories that are sharing some of their state. This is only intended - ;; to be called by ephemeral, only-local references to RuleOrderedActivation instances used to - ;; search for activations to remove from memory when performing `remove-activations!` operations. - ;; The reason this mutable state exists at all is to "flip" a single instance of a RuleOrderedActivation - ;; from identity to value equality based comparable when doing the "two-pass" removal search operation - ;; of `remove-activations!`. This avoids having to create different instances for each pass. - (using-token-identity! [this bool] - (set! use-token-identity? bool) - this) - Object - ;; Two RuleOrderedActivation instances should be equal if and only if their - ;; activation is equal. Note that if the node of two activations is the same, - ;; their rule-load-order must be the same. Using a deftype wrapper allows us to - ;; use Clojure equality to determine this while placing the wrapper in a Java data - ;; structure that uses Java equality; the Java equality check will simply end up calling - ;; Clojure equality checks. - (equals [this other] - ;; Note that the .equals method is only called by PriorityQueue.remove, and the object provided - ;; to the .remove method will never be identical to any object in the queue. A short-circuiting - ;; check for reference equality would therefore be pointless here because it would never be true. - (boolean - (when (instance? RuleOrderedActivation other) - (let [^RuleOrderedActivation other other] - (and - ;; If the node-id of two nodes is equal then we can assume that the nodes are equal. - (= node-id - (.node-id other)) - - ;; We check with identity based semantics on the other when the use-token-identity? field - ;; indicates to do so. - (if (or use-token-identity? (.-use-token-identity? other)) - (fast-token-compare identical? token (.-token other)) - (fast-token-compare = token (.-token other)))))))))) - -#?(:clj - (defn- ->rule-ordered-activation - "Take an activation from the engine and wrap it in a map that includes information - on the rule load order. In Clojure, as opposed to ClojureScript, each activation should - be wrapped in this way exactly once (that is, the value of the :activation key should - be an activation from the engine.)" - ([activation] - (->rule-ordered-activation activation false)) - ([activation use-token-identity?] - (let [node (:node activation)] - (RuleOrderedActivation. (:id node) - (:token activation) - activation - (or (-> node - :production - meta - :clara.rules.compiler/rule-load-order) - 0) - use-token-identity?))))) - -#?(:clj - (defn- queue-activations! - "Add activations to a queue. The wrap-rule-order? option should be true - unless the activations in question have previously been wrapped." - ([^java.util.Queue pq activations] - (queue-activations! pq activations true)) - ([^java.util.Queue pq activations wrap-rule-order?] - (if wrap-rule-order? - (doseq [act activations] - (.add pq (->rule-ordered-activation act))) - (doseq [act activations] - (.add pq act))) - pq))) - -#?(:clj - (defn- ->activation-priority-queue - "Given activations, create a priority queue based on rule ordering. - The activations should be wrapped by using the wrap-rule-order? option - if they have not been wrapped already." - ([activations] - (->activation-priority-queue activations true)) - ([activations wrap-rule-order?] - (let [init-cnt (count activations) - ;; Note that 11 is the default initial value; there is no constructor - ;; for PriorityQueue that takes a custom comparator and does not require - ;; an initial size to be passed. - pq (java.util.PriorityQueue. (if (pos? init-cnt) init-cnt 11) - (fn [^RuleOrderedActivation x - ^RuleOrderedActivation y] - (compare (.rule-load-order x) - (.rule-load-order y))))] - (queue-activations! pq activations wrap-rule-order?))))) - -(declare ->PersistentLocalMemory) - -;;; Transient local memory implementation. Typically only persistent memory will be visible externally. - -(deftype TransientLocalMemory [rulebase - activation-group-sort-fn - activation-group-fn - alphas-fn - ^:unsynchronized-mutable alpha-memory - ^:unsynchronized-mutable beta-memory - ^:unsynchronized-mutable accum-memory - ^:unsynchronized-mutable production-memory - ^:unsynchronized-mutable #?(:clj ^java.util.NavigableMap activation-map :cljs activation-map)] - - IMemoryReader - (get-rulebase [memory] rulebase) - - (get-alphas-fn [memory] alphas-fn) - - (get-elements [memory node bindings] - (get (get alpha-memory (:id node) {}) - bindings - [])) - - (get-elements-all [memory node] - (sequence - cat - (vals - (get alpha-memory (:id node) {})))) - - (get-tokens [memory node bindings] - (get (get beta-memory (:id node) {}) - bindings - [])) - - (get-tokens-all [memory node] - (sequence - cat - (vals (get beta-memory (:id node) {})))) - - (get-accum-reduced [memory node join-bindings fact-bindings] - (get-in accum-memory [(:id node) join-bindings fact-bindings] ::no-accum-reduced)) - - (get-accum-reduced-all [memory node join-bindings] - (get - (get accum-memory (:id node) {}) - join-bindings)) - - ;; TODO: rename existing get-accum-reduced-all and use something better here. - (get-accum-reduced-complete [memory node] - (for [[join-binding joins] (get accum-memory (:id node) {}) - [fact-binding reduced] joins] - {:join-bindings join-binding - :fact-bindings fact-binding - :result reduced})) - - (get-insertions [memory node token] - (get - (get production-memory (:id node) {}) - token - [])) - - (get-insertions-all [memory node] - (get production-memory (:id node) {})) - - (get-activations [memory] - (into [] - (comp cat - (map (fn [^RuleOrderedActivation a] - (.activation a)))) - (vals activation-map))) - - ITransientMemory - #?(:clj - (add-elements! [memory node join-bindings elements] - (let [binding-element-map (get alpha-memory (:id node) {}) - previous-elements (get binding-element-map join-bindings)] - - (cond - ;; When changing existing persistent collections, just add on - ;; the new elements. - (coll? previous-elements) - (set! alpha-memory - (assoc! alpha-memory - (:id node) - (assoc binding-element-map - join-bindings - (into previous-elements elements)))) - - ;; Already mutable, so update-in-place. - previous-elements - (add-all! previous-elements elements) - - ;; No previous. We can just leave it persistent if it is - ;; until we actually need to modify anything. This avoids - ;; unnecessary copying. - elements - (set! alpha-memory - (assoc! alpha-memory - (:id node) - (assoc binding-element-map - join-bindings - elements)))))) - :cljs - (add-elements! [memory node join-bindings elements] - (let [binding-element-map (get alpha-memory (:id node) {}) - previous-elements (get binding-element-map join-bindings [])] - - (set! alpha-memory - (assoc! alpha-memory - (:id node) - (assoc binding-element-map join-bindings (into previous-elements elements))))))) - - (remove-elements! [memory node join-bindings elements] - #?(:clj - ;; Do nothing when no elements to remove. - (when-not (coll-empty? elements) - (let [binding-element-map (get alpha-memory (:id node) {}) - previous-elements (get binding-element-map join-bindings)] - (cond - ;; Do nothing when no previous elements to remove from. - (coll-empty? previous-elements) - [] - - ;; Convert persistent collection to a mutable one prior to calling remove-first-of-each! - ;; alpha-memory needs to be updated this time since there is now going to be a mutable - ;; collection associated in this memory location instead. - (coll? previous-elements) - (let [remaining-elements (->linked-list previous-elements) - removed-elements (first (remove-first-of-each! elements remaining-elements))] - ;; If there are no remaining elements under a binding group for the node remove the binding group. - ;; This allows these binding values to be garbage collected. - (let [new-bindings-map (if (.isEmpty ^java.util.List remaining-elements) - (dissoc binding-element-map join-bindings) - (assoc binding-element-map - join-bindings - remaining-elements))] - (set! alpha-memory - (assoc! alpha-memory - (:id node) - new-bindings-map)) - removed-elements)) - - ;; Already mutable, so we do not need to re-associate to alpha-memory. - previous-elements - (let [removed-elements (first (remove-first-of-each! elements previous-elements))] - (when (.isEmpty ^java.util.List previous-elements) - (set! alpha-memory - (assoc! alpha-memory - (:id node) - (dissoc binding-element-map join-bindings)))) - removed-elements)))) - :cljs - (let [binding-element-map (get alpha-memory (:id node) {}) - previous-elements (get binding-element-map join-bindings []) - [removed-elements filtered-elements] (remove-first-of-each elements previous-elements) - new-bindings-map (if (seq filtered-elements) - (assoc binding-element-map join-bindings filtered-elements) - (dissoc binding-element-map join-bindings))] - - (set! alpha-memory - (assoc! alpha-memory - (:id node) - new-bindings-map)) - - ;; Return the removed elements. - removed-elements))) - - (add-tokens! [memory node join-bindings tokens] - #?(:clj - (let [binding-token-map (get beta-memory (:id node) {}) - previous-tokens (get binding-token-map join-bindings)] - ;; The reasoning here is the same as in add-elements! impl above. - (cond - (coll? previous-tokens) - (set! beta-memory - (assoc! beta-memory - (:id node) - (assoc binding-token-map - join-bindings - (into previous-tokens tokens)))) - - previous-tokens - (add-all! previous-tokens tokens) - - tokens - (set! beta-memory - (assoc! beta-memory - (:id node) - (assoc binding-token-map - join-bindings - tokens))))) - :cljs - (let [binding-token-map (get beta-memory (:id node) {}) - previous-tokens (get binding-token-map join-bindings [])] - - (set! beta-memory - (assoc! beta-memory - (:id node) - (assoc binding-token-map join-bindings (into previous-tokens tokens))))))) - - (remove-tokens! [memory node join-bindings tokens] - #?(:clj - ;; The reasoning here is the same as remove-elements! - (when-not (coll-empty? tokens) - (let [binding-token-map (get beta-memory (:id node) {}) - previous-tokens (get binding-token-map join-bindings)] - (if - (coll-empty? previous-tokens) - [] - - (let [;; Attempt to remove tokens using the faster indentity-based equality first since - ;; most of the time this is all we need and it can be much faster. Any token that - ;; wasn't removed via identity, has to be "retried" with normal value-based - ;; equality though since those semantics are supported within the engine. This - ;; slower path should be rare for any heavy retraction flows - such as those that come - ;; via truth maintenance. - two-pass-remove! (fn [remaining-tokens tokens] - (let [[removed-tokens not-removed-tokens] - (remove-first-of-each! tokens - remaining-tokens - (fn [t1 t2] - (fast-token-compare identical? t1 t2)))] - - (if-let [other-removed (and (seq not-removed-tokens) - (-> not-removed-tokens - (remove-first-of-each! remaining-tokens - (fn [t1 t2] - (fast-token-compare = t1 t2))) - first - seq))] - (into removed-tokens other-removed) - removed-tokens)))] - (cond - (coll? previous-tokens) - (let [remaining-tokens (->linked-list previous-tokens) - removed-tokens (two-pass-remove! remaining-tokens tokens) - new-tokens-map (if (.isEmpty ^java.util.List remaining-tokens) - (dissoc binding-token-map join-bindings) - (assoc binding-token-map join-bindings remaining-tokens))] - (set! beta-memory - (assoc! beta-memory - (:id node) - new-tokens-map)) - removed-tokens) - - previous-tokens - (let [removed-tokens (two-pass-remove! previous-tokens tokens)] - (when (.isEmpty ^java.util.List previous-tokens) - (set! beta-memory - (assoc! beta-memory - (:id node) - (dissoc binding-token-map join-bindings)))) - - removed-tokens)))))) - :cljs - (let [binding-token-map (get beta-memory (:id node) {}) - previous-tokens (get binding-token-map join-bindings []) - [removed-tokens filtered-tokens] (remove-first-of-each tokens previous-tokens) - new-tokens-map (if (seq filtered-tokens) - (assoc binding-token-map join-bindings filtered-tokens) - (dissoc binding-token-map join-bindings))] - - (set! beta-memory - (assoc! beta-memory - (:id node) - new-tokens-map)) - - ;; Return the removed tokens. - removed-tokens))) - - (add-accum-reduced! [memory node join-bindings accum-result fact-bindings] - - (set! accum-memory - (assoc! accum-memory - (:id node) - (assoc-in (get accum-memory (:id node) {}) - [join-bindings fact-bindings] - accum-result)))) - - (remove-accum-reduced! [memory node join-bindings fact-bindings] - (let [node-id (:id node) - node-id-mem (get accum-memory node-id {}) - join-mem (dissoc (get node-id-mem join-bindings) fact-bindings) - node-id-mem (if (empty? join-mem) - (dissoc node-id-mem join-bindings) - (assoc node-id-mem join-bindings join-mem))] - (set! accum-memory - (if (empty? node-id-mem) - (dissoc! accum-memory - node-id) - (assoc! accum-memory - node-id - node-id-mem))))) - - ;; The value under each token in the map should be a sequence - ;; of sequences of facts, with each inner sequence coming from a single - ;; rule activation. - (add-insertions! [memory node token facts] - (let [token-facts-map (get production-memory (:id node) {})] - (set! production-memory - (assoc! production-memory - (:id node) - (update token-facts-map token conj facts))))) - - (remove-insertions! [memory node tokens] - - ;; Remove the facts inserted from the given token. - (let [token-facts-map (get production-memory (:id node) {}) - ;; Get removed tokens for the caller. - [results - new-token-facts-map] - - (loop [results (transient {}) - token-map (transient token-facts-map) - to-remove tokens] - (if-let [head-token (first to-remove)] - ;; Don't use contains? due to http://dev.clojure.org/jira/browse/CLJ-700 - (if-let [token-insertions (get token-map head-token)] - (let [;; There is no particular significance in removing the - ;; first group; we just need to remove exactly one. - [removed-facts & remaining-facts] token-insertions - removed-insertion-map (if (not-empty remaining-facts) - (assoc! token-map head-token remaining-facts) - (dissoc! token-map head-token)) - prev-token-result (get results head-token [])] - (recur (assoc! results head-token (into prev-token-result removed-facts)) - removed-insertion-map - (rest to-remove))) - ;; If the token isn't present in the insertions just try the next one. - (recur results token-map (rest to-remove))) - [(persistent! results) - (persistent! token-map)]))] - - ;; Clear the tokens and update the memory. - (set! production-memory - (if (not-empty new-token-facts-map) - (assoc! production-memory - (:id node) - new-token-facts-map) - (dissoc! production-memory (:id node)))) - results)) - - #?(:clj - (add-activations! - [memory production new-activations] - (let [activation-group (activation-group-fn production) - previous (.get activation-map activation-group)] - ;; The reasoning here is the same as in add-elements! impl above. - (cond - previous - (queue-activations! previous new-activations) - - (not (coll-empty? new-activations)) - (.put activation-map - activation-group - (->activation-priority-queue new-activations))))) - :cljs - (add-activations! - [memory production new-activations] - (let [activation-group (activation-group-fn production) - previous (get activation-map activation-group)] - (set! activation-map - (assoc activation-map - activation-group - (if previous - (into previous new-activations) - new-activations)))))) - - #?(:clj - (pop-activation! - [memory] - (when (not (.isEmpty activation-map)) - (let [entry (.firstEntry activation-map) - key (.getKey entry) - ^java.util.Queue value (.getValue entry) - - ;; An empty value is illegal and should be removed by an action - ;; that creates one (e.g. a remove-activations! call). - ^RuleOrderedActivation activation (.remove value)] - - ;; This activation group is empty now, so remove it from - ;; the map entirely. - (when (.isEmpty value) - (.remove activation-map key)) - - ;; Return the selected activation. - (.activation activation)))) - - :cljs - (pop-activation! - [memory] - (when (not (empty? activation-map)) - (let [[key value] (first activation-map) - remaining (rest value)] - - (set! activation-map - (if (empty? remaining) - (dissoc activation-map key) - (assoc activation-map key remaining))) - (first value))))) - - #?(:clj - (next-activation-group - [memory] - (when (not (.isEmpty activation-map)) - (let [entry (.firstEntry activation-map)] - (.getKey entry)))) - :cljs - (next-activation-group - [memory] - (let [[key val] (first activation-map)] - key))) - - (remove-activations! [memory production to-remove] - #?(:clj - ;; The reasoning here is the same as remove-elements! - (when-not (coll-empty? to-remove) - (let [activation-group (activation-group-fn production) - ^java.util.Queue activations (.get activation-map activation-group) - removed-activations (java.util.LinkedList.) - unremoved-activations (java.util.LinkedList.)] - - (if (coll-empty? activations) - ;; If there are no activations present under the group - ;; then we can't remove any. - [[] to-remove] - ;; Remove as many activations by identity as possible first. - (let [not-removed (loop [to-remove-item (first to-remove) - to-remove (next to-remove) - not-removed (transient [])] - (if to-remove-item - (let [^RuleOrderedActivation act (->rule-ordered-activation to-remove-item true)] - (if (.remove activations act) - (do - (.add removed-activations (.activation act)) - ;; The activations that are not removed in the identity checking sweep - ;; are a superset of the activations that are removed after the equality - ;; sweep finishes so we can just create the list of unremoved activations - ;; during that sweep. - (recur (first to-remove) (next to-remove) not-removed)) - (recur (first to-remove) (next to-remove) (conj! not-removed act)))) - (persistent! not-removed)))] - - ;; There may still be activations not removed since the removal may be based on value-based - ;; equality semantics. Retractions in the engine do not require that identical object references - ;; are given to remove object values that are equal. - (doseq [^RuleOrderedActivation act not-removed] - (if (.remove activations (using-token-identity! act false)) - (.add removed-activations (.activation act)) - (.add unremoved-activations (.activation act)))) - - (when (coll-empty? activations) - (.remove activation-map activation-group)) - - [(java.util.Collections/unmodifiableList removed-activations) - (java.util.Collections/unmodifiableList unremoved-activations)])))) - :cljs - (let [activation-group (activation-group-fn production) - current-activations (get activation-map activation-group) - [removed-activations remaining-activations unremoved-activations] - (remove-first-of-each - to-remove - current-activations)] - (set! activation-map (assoc activation-map - activation-group - remaining-activations)) - [removed-activations unremoved-activations]))) - - #?(:clj - (clear-activations! - [memory] - (.clear activation-map)) - :cljs - (clear-activations! - [memory] - (set! activation-map (sorted-map-by activation-group-sort-fn)))) - - (to-persistent! [memory] - #?(:clj - ;; Be sure to remove all transients and internal mutable - ;; collections used in memory. Convert any collection that is - ;; not already a Clojure persistent collection. - (let [->persistent-coll #(if (coll? %) - % - (seq %)) - update-vals (fn [m update-fn] - (->> m - (reduce-kv (fn [m k v] - (assoc! m k (update-fn v))) - (transient m)) - persistent!)) - persistent-vals #(update-vals % ->persistent-coll)] - (->PersistentLocalMemory rulebase - activation-group-sort-fn - activation-group-fn - alphas-fn - (update-vals (persistent! alpha-memory) persistent-vals) - (update-vals (persistent! beta-memory) persistent-vals) - (persistent! accum-memory) - (persistent! production-memory) - (into {} - (map (juxt key (comp ->persistent-coll val))) - activation-map))) - :cljs - (->PersistentLocalMemory rulebase - activation-group-sort-fn - activation-group-fn - alphas-fn - (persistent! alpha-memory) - (persistent! beta-memory) - (persistent! accum-memory) - (persistent! production-memory) - (into {} - (for [[key val] activation-map] - [key val])))))) - -(defrecord PersistentLocalMemory [rulebase - activation-group-sort-fn - activation-group-fn - alphas-fn - alpha-memory - beta-memory - accum-memory - production-memory - activation-map] - IMemoryReader - (get-rulebase [memory] rulebase) - - (get-alphas-fn [memory] alphas-fn) - - (get-elements [memory node bindings] - (get (get alpha-memory (:id node) {}) - bindings - [])) - - (get-elements-all [memory node] - (sequence - cat - (vals - (get alpha-memory (:id node) {})))) - - (get-tokens [memory node bindings] - (get (get beta-memory (:id node) {}) - bindings - [])) - - (get-tokens-all [memory node] - (sequence - cat - (vals (get beta-memory (:id node) {})))) - - (get-accum-reduced [memory node join-bindings fact-bindings] - ;; nil is a valid previously reduced value that can be found in the map. - ;; Return ::no-accum-reduced instead of nil when there is no previously - ;; reduced value in memory. - (get-in accum-memory [(:id node) join-bindings fact-bindings] ::no-accum-reduced)) - - (get-accum-reduced-all [memory node join-bindings] - (get - (get accum-memory (:id node) {}) - join-bindings)) - - (get-accum-reduced-complete [memory node] - (for [[join-binding joins] (get accum-memory (:id node) {}) - [fact-binding reduced] joins] - {:join-bindings join-binding - :fact-bindings fact-binding - :result reduced})) - - (get-insertions [memory node token] - (get - (get production-memory (:id node) {}) - token - [])) - - (get-insertions-all [memory node] - (get production-memory (:id node) {})) - - (get-activations [memory] - #?(:clj - (into [] - (comp cat - (map (fn [^RuleOrderedActivation a] - (.activation a)))) - (vals activation-map)) - - :cljs - (apply concat (vals activation-map)))) - - IPersistentMemory - (to-transient [memory] - #?(:clj - (TransientLocalMemory. rulebase - activation-group-sort-fn - activation-group-fn - alphas-fn - (transient alpha-memory) - (transient beta-memory) - (transient accum-memory) - (transient production-memory) - (let [treemap (java.util.TreeMap. ^java.util.Comparator activation-group-sort-fn)] - (doseq [[activation-group activations] activation-map] - (.put treemap - activation-group - (->activation-priority-queue activations false))) - treemap)) - :cljs - (let [activation-map (reduce - (fn [treemap [activation-group activations]] - (let [previous (get treemap activation-group)] - (assoc treemap activation-group - (if previous - (into previous activations) - activations)))) - (sorted-map-by activation-group-sort-fn) - activation-map)] - (TransientLocalMemory. rulebase - activation-group-sort-fn - activation-group-fn - alphas-fn - (transient alpha-memory) - (transient beta-memory) - (transient accum-memory) - (transient production-memory) - (reduce - (fn [treemap [activation-group activations]] - (let [previous (get treemap activation-group)] - (assoc treemap activation-group - (if previous - (into previous activations) - activations)))) - (sorted-map-by activation-group-sort-fn) - activation-map)))))) - -(defn local-memory - "Creates an persistent local memory for the given rule base." - [rulebase activation-group-sort-fn activation-group-fn alphas-fn] - - (->PersistentLocalMemory rulebase - activation-group-sort-fn - activation-group-fn - alphas-fn - {} - {} - {} - {} - {})) diff --git a/src/main/clojure/clara/rules/platform.clj b/src/main/clojure/clara/rules/platform.clj new file mode 100644 index 00000000..d514f288 --- /dev/null +++ b/src/main/clojure/clara/rules/platform.clj @@ -0,0 +1,115 @@ +(ns clara.rules.platform + "This namespace is for internal use and may move in the future. + Platform unified code Clojure/ClojureScript." + (:import [java.lang IllegalArgumentException] + [java.util LinkedHashMap])) + +(defn throw-error + "Throw an error with the given description string." + [^String description] + (throw (IllegalArgumentException. description))) + +(defn query-param + "Coerces a query param to a parameter keyword such as :?param, if an unsupported type is + supplied then an exception will be thrown" + [p] + (cond + (keyword? p) p + (symbol? p) (keyword p) + :else + (throw-error (str "Query bindings must be specified as a keyword or symbol: " p)))) + +;; This class wraps Clojure objects to ensure Clojure's equality and hash +;; semantics are visible to Java code. This allows these Clojure objects +;; to be safely used in things like Java Sets or Maps. +;; This class also accepts and stores the hash code, since it almost always +;; will be used once and generally more than once. +(deftype JavaEqualityWrapper [wrapped ^int hash-code] + + Object + (equals [this other] + + (cond + + ;; There are some cases where the inserted and retracted facts could be identical, particularly + ;; if user code in the RHS has caches, so we go ahead and check for identity as a first-pass check, + ;; but there are probably aren't enough cases where the facts are identical to make doing a full sweep + ;; on identity first worthwhile, particularly since in practice the hash check will make the vast majority + ;; of .equals calls that return false quite fast. + (identical? wrapped (.wrapped ^JavaEqualityWrapper other)) + true + + (not (== hash-code (.hash_code ^JavaEqualityWrapper other))) + false + + :else (= wrapped (.wrapped ^JavaEqualityWrapper other)))) + + (hashCode [this] hash-code)) + +(defn jeq-wrap + "wraps the value with a JavaEqualityWrapper" + ^JavaEqualityWrapper [value] + (JavaEqualityWrapper. value (hash value))) + +(defn group-by-seq + "Groups the items of the given coll by f to each item. Returns a seq of tuples of the form + [f-val xs] where xs are items from the coll and f-val is the result of applying f to any of + those xs. Each x in xs has the same value (f x). xs will be in the same order as they were + found in coll. + The behavior is similar to calling `(seq (group-by f coll))` However, the returned seq will + always have consistent ordering from process to process. The ordering is insertion order + as new (f x) values are found traversing the given coll collection in its seq order. The + returned order is made consistent to ensure that relevant places within the rules engine that + use this grouping logic have deterministic behavior across different processes." + [f coll] + (let [^java.util.Map m (reduce (fn [^java.util.Map m x] + (let [k (f x) + ;; Use Java's hashcode for performance reasons as + ;; discussed at https://github.com/cerner/clara-rules/issues/393 + wrapper (jeq-wrap k) + xs (or (.get m wrapper) + (transient []))] + (.put m wrapper (conj! xs x))) + m) + (LinkedHashMap.) + coll) + it (.iterator (.entrySet m))] + ;; Explicitly iterate over a Java iterator in order to avoid running into issues as + ;; discussed in http://dev.clojure.org/jira/browse/CLJ-1738 + (loop [coll (transient [])] + (if (.hasNext it) + (let [^java.util.Map$Entry e (.next it)] + (recur (conj! coll [(.wrapped ^JavaEqualityWrapper (.getKey e)) (persistent! (.getValue e))]))) + (persistent! coll))))) + +(defmacro thread-local-binding + "Wraps given body in a try block, where it sets each given ThreadLocal binding + and removes it in finally block." + [bindings & body] + (when-not (vector? bindings) + (throw (ex-info "Binding needs to be a vector." + {:bindings bindings}))) + (when-not (even? (count bindings)) + (throw (ex-info "Needs an even number of forms in binding vector" + {:bindings bindings}))) + (let [binding-pairs (partition 2 bindings)] + `(try + ~@(for [[tl v] binding-pairs] + `(.set ~tl ~v)) + ~@body + (finally + ~@(for [[tl] binding-pairs] + `(.remove ~tl)))))) + +(defmacro eager-for + "A for wrapped with a doall to force realisation. Usage is the same as regular for." + [& body] + `(doall (for ~@body))) + +(defmacro compute-for + [bindings & body] + `(eager-for + [~@bindings + :let [result# (do ~@body)] + :when result#] + result#)) diff --git a/src/main/clojure/clara/rules/platform.cljc b/src/main/clojure/clara/rules/platform.cljc deleted file mode 100644 index 9470e282..00000000 --- a/src/main/clojure/clara/rules/platform.cljc +++ /dev/null @@ -1,115 +0,0 @@ -(ns clara.rules.platform - "This namespace is for internal use and may move in the future. - Platform unified code Clojure/ClojureScript.") - -(defn throw-error - "Throw an error with the given description string." - [^String description] - (throw #?(:clj (IllegalArgumentException. description) :cljs (js/Error. description)))) - -(defn query-param - "Coerces a query param to a parameter keyword such as :?param, if an unsupported type is - supplied then an exception will be thrown" - [p] - (cond - (keyword? p) p - (symbol? p) (keyword p) - :else - (throw-error (str "Query bindings must be specified as a keyword or symbol: " p)))) - -;; This class wraps Clojure objects to ensure Clojure's equality and hash -;; semantics are visible to Java code. This allows these Clojure objects -;; to be safely used in things like Java Sets or Maps. -;; This class also accepts and stores the hash code, since it almost always -;; will be used once and generally more than once. -#?(:clj - (deftype JavaEqualityWrapper [wrapped ^int hash-code] - - Object - (equals [this other] - (and (instance? JavaEqualityWrapper other) - (= wrapped (.wrapped ^JavaEqualityWrapper other)))) - - (hashCode [this] - hash-code))) - -#?(:clj - (defn group-by-seq - "Groups the items of the given coll by f to each item. Returns a seq of tuples of the form - [f-val xs] where xs are items from the coll and f-val is the result of applying f to any of - those xs. Each x in xs has the same value (f x). xs will be in the same order as they were - found in coll. - The behavior is similar to calling `(seq (group-by f coll))` However, the returned seq will - always have consistent ordering from process to process. The ordering is insertion order - as new (f x) values are found traversing the given coll collection in its seq order. The - returned order is made consistent to ensure that relevant places within the rules engine that - use this grouping logic have deterministic behavior across different processes." - [f coll] - (let [^java.util.Map m (reduce (fn [^java.util.Map m x] - (let [k (f x) - ;; Use Java's hashcode for performance reasons as - ;; discussed at https://github.com/cerner/clara-rules/issues/393 - wrapper (JavaEqualityWrapper. k - (if (nil? k) - (int 0) - (int (.hashCode ^Object k)))) - xs (or (.get m wrapper) - (transient []))] - (.put m wrapper (conj! xs x))) - m) - (java.util.LinkedHashMap.) - coll) - it (.iterator (.entrySet m))] - ;; Explicitly iterate over a Java iterator in order to avoid running into issues as - ;; discussed in http://dev.clojure.org/jira/browse/CLJ-1738 - (loop [coll (transient [])] - (if (.hasNext it) - (let [^java.util.Map$Entry e (.next it)] - (recur (conj! coll [(.wrapped ^JavaEqualityWrapper (.getKey e)) (persistent! (.getValue e))]))) - (persistent! coll))))) - :cljs - (def group-by-seq (comp seq clojure.core/group-by))) - -#?(:clj - (defn tuned-group-by - "Equivalent of the built-in group-by, but tuned for when there are many values per key." - [f coll] - (->> coll - (reduce (fn [map value] - (let [k (f value) - items (or (.get ^java.util.HashMap map k) - (transient []))] - (.put ^java.util.HashMap map k (conj! items value))) - map) - (java.util.HashMap.)) - (reduce (fn [map [key value]] - (assoc! map key (persistent! value))) - (transient {})) - (persistent!))) - :cljs - (def tuned-group-by clojure.core/group-by)) - -#?(:clj - (defmacro thread-local-binding - "Wraps given body in a try block, where it sets each given ThreadLocal binding - and removes it in finally block." - [bindings & body] - (when-not (vector? bindings) - (throw (ex-info "Binding needs to be a vector." - {:bindings bindings}))) - (when-not (even? (count bindings)) - (throw (ex-info "Needs an even number of forms in binding vector" - {:bindings bindings}))) - (let [binding-pairs (partition 2 bindings)] - `(try - ~@(for [[tl v] binding-pairs] - `(.set ~tl ~v)) - ~@body - (finally - ~@(for [[tl] binding-pairs] - `(.remove ~tl))))))) - -(defmacro eager-for - "A for wrapped with a doall to force realisation. Usage is the same as regular for." - [& body] - `(doall (for ~@body))) diff --git a/src/main/clojure/clara/rules/schema.cljc b/src/main/clojure/clara/rules/schema.clj similarity index 91% rename from src/main/clojure/clara/rules/schema.cljc rename to src/main/clojure/clara/rules/schema.clj index c9e646ff..bb63e13a 100644 --- a/src/main/clojure/clara/rules/schema.cljc +++ b/src/main/clojure/clara/rules/schema.clj @@ -1,8 +1,14 @@ (ns clara.rules.schema "Schema definition of Clara data structures using Prismatic's Schema library. This includes structures for rules and queries, as well as the schema for the underlying Rete network itself. This can be used by tools or other libraries working with rules." - (:require [schema.core :as s])) + (:require [schema.core :as s]) + (:import [ham_fisted UnsharedLongHashMap])) +(def MutableLongHashMap + UnsharedLongHashMap) + +(def Function + (s/pred ifn? "ifn?")) (s/defn condition-type :- (s/enum :or :not :and :exists :fact :accumulator :test) "Returns the type of node in a LHS condition expression." @@ -10,14 +16,13 @@ (if (map? condition) ; Leaf nodes are maps, per the schema (cond - (:type condition) :fact - (:accumulator condition) :accumulator - :else :test) + (:type condition) :fact + (:accumulator condition) :accumulator + :else :test) ;; Otherwise the node must a sequential that starts with the boolean operator. (first condition))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Rule and query structure schema. @@ -30,8 +35,7 @@ ;; Original constraints preserved for tooling in case a transformation was applied to the condition. (s/optional-key :original-constraints) [SExpr] (s/optional-key :fact-binding) s/Keyword - (s/optional-key :args) s/Any - }) + (s/optional-key :args) s/Any}) (def AccumulatorCondition {:accumulator s/Any @@ -67,6 +71,7 @@ (s/optional-key :doc) s/Str (s/optional-key :props) {s/Keyword s/Any} (s/optional-key :env) {s/Keyword s/Any} + (s/optional-key :handler) (s/maybe Function) :lhs [Condition] :rhs s/Any}) @@ -141,20 +146,19 @@ ;; A graph representing the beta side of the rete network. (def BetaGraph {;; Edges from parent to child nodes. - :forward-edges {s/Int #{s/Int}} + :forward-edges MutableLongHashMap ;; Edges from child to parent nodes. - :backward-edges {s/Int #{s/Int}} + :backward-edges MutableLongHashMap ;; Map of identifier to condition nodes. - :id-to-condition-node {s/Int (s/cond-pre (s/eq :clara.rules.compiler/root-condition) - ConditionNode)} + :id-to-condition-node MutableLongHashMap ;; Map of identifier to query or rule nodes. - :id-to-production-node {s/Int ProductionNode} + :id-to-production-node MutableLongHashMap ;; Map of identifier to new bindings created by the corresponding node. - :id-to-new-bindings {s/Int #{s/Keyword}}}) + :id-to-new-bindings MutableLongHashMap}) (defn tuple "Given `items`, a list of schemas, will generate a schema to validate that a vector contains and is in the order provided @@ -200,4 +204,4 @@ ;; deserialization. In such events the compile-ctx would only be valuable when the environment ;; where the Session is being deserialized doesn't match that of the serialization, ie functions ;; and symbols cannot be resolved on the deserialization side. - {(tuple s/Int s/Keyword) (tuple (s/pred ifn? "ifn?") NodeCompilationValue)}) \ No newline at end of file + {(tuple s/Int s/Keyword) (tuple Function NodeCompilationValue)}) diff --git a/src/main/clojure/clara/rules/test_rules_data.clj b/src/main/clojure/clara/rules/test_rules_data.clj index dac16da5..8239fb4a 100644 --- a/src/main/clojure/clara/rules/test_rules_data.clj +++ b/src/main/clojure/clara/rules/test_rules_data.clj @@ -5,23 +5,22 @@ (ns clara.rules.test-rules-data (:require [clara.rules] - [clara.rules.testfacts] - [clara.rules.compiler :as com])) + [clara.rules.testfacts])) (def the-rules [{:doc "Rule to determine whether it is indeed cold and windy." :name "clara.rules.test-rules-data/is-cold-and-windy-data" - :lhs [{:type (if (com/compiling-cljs?) 'clara.rules.testfacts/Temperature 'clara.rules.testfacts.Temperature) + :lhs [{:type clara.rules.testfacts.Temperature :constraints '[(< temperature 20) (== ?t temperature)]} - {:type (if (com/compiling-cljs?) 'clara.rules.testfacts/WindSpeed 'clara.rules.testfacts.WindSpeed) + {:type clara.rules.testfacts.WindSpeed :constraints '[(> windspeed 30) (== ?w windspeed)]}] :rhs '(clara.rules/insert! (clara.rules.testfacts/->ColdAndWindy ?t ?w))} {:name "clara.rules.test-rules-data/find-cold-and-windy-data" :lhs [{:fact-binding :?fact - :type (if (com/compiling-cljs?) 'clara.rules.testfacts/ColdAndWindy 'clara.rules.testfacts.ColdAndWindy) + :type clara.rules.testfacts.ColdAndWindy :constraints []}] :params #{}}]) @@ -35,4 +34,4 @@ (defn weather-rules-with-keyword-names "Return some weather rules using keyword names" [] - the-rules-with-keyword-names) \ No newline at end of file + the-rules-with-keyword-names) diff --git a/src/main/clojure/clara/rules/testfacts.cljc b/src/main/clojure/clara/rules/testfacts.clj similarity index 99% rename from src/main/clojure/clara/rules/testfacts.cljc rename to src/main/clojure/clara/rules/testfacts.clj index 41fff1d7..f11b2ac9 100644 --- a/src/main/clojure/clara/rules/testfacts.cljc +++ b/src/main/clojure/clara/rules/testfacts.clj @@ -11,7 +11,6 @@ (defrecord LousyWeather []) (defrecord TemperatureHistory [temperatures]) - ;; Test facts for chained rules. (defrecord First []) (defrecord Second []) diff --git a/src/main/clojure/clara/rules/update_cache/cancelling.clj b/src/main/clojure/clara/rules/update_cache/cancelling.clj index cb13cc12..74e29623 100644 --- a/src/main/clojure/clara/rules/update_cache/cancelling.clj +++ b/src/main/clojure/clara/rules/update_cache/cancelling.clj @@ -1,39 +1,13 @@ (ns clara.rules.update-cache.cancelling - (:require [clara.rules.update-cache.core :as uc]) + (:require [clara.rules.update-cache.core :as uc] + [clara.rules.platform :refer [jeq-wrap]] + [ham-fisted.api :as hf] + [ham-fisted.mut-map :as hm]) (:import [java.util List Map LinkedList - LinkedHashMap - Collections])) - -;;; We need a wrapper to use Clojure equality semantics inside -;;; a Java collection. Furthermore, since we know we will need to do -;;; a hash operation for each such wrapper created anyway we can ensure -;;; that if the hashes of two facts are not equal that the equals implementation -;;; here will quickly return false. -(deftype FactWrapper [fact ^int fact-hash] - - Object - (equals [this other] - - (cond - - ;; There are some cases where the inserted and retracted facts could be identical, particularly - ;; if user code in the RHS has caches, so we go ahead and check for identity as a first-pass check, - ;; but there are probably aren't enough cases where the facts are identical to make doing a full sweep - ;; on identity first worthwhile, particularly since in practice the hash check will make the vast majority - ;; of .equals calls that return false quite fast. - (identical? fact (.fact ^FactWrapper other)) - true - - (not (== fact-hash (.fact_hash ^FactWrapper other))) - false - - :else (= fact (.fact ^FactWrapper other)))) - - (hashCode [this] fact-hash)) - + LinkedHashMap])) ;;; These functions essentially allow us to use a Java map to create a set that stores ;;; the frequency of its items. Note that when multiple instances of a fact are added @@ -43,14 +17,13 @@ ;;; memory operations look for matches on identity first in tokens before falling back to matching ;;; on equality. (defn inc-fact-count! [^Map m fact] - (let [wrapper (FactWrapper. fact (hash fact)) - ^List current-val (.get m wrapper)] - (if current-val - (.add current-val fact) - (.put m wrapper (LinkedList. [fact]))))) + (let [wrapper (jeq-wrap fact) + ^List result (or (.get m wrapper) (LinkedList.))] + (hm/compute-if-absent! m wrapper (constantly result)) + (.add result fact))) (defn dec-fact-count! [^Map m fact] - (let [wrapper (FactWrapper. fact (hash fact)) + (let [wrapper (jeq-wrap fact) ;; Note that we specifically use a LinkedList type hint here since we ;; use methods from multiple interfaces here, namely List and Deque. ^LinkedList current-val (.get m wrapper)] @@ -69,24 +42,7 @@ (defn map->vals-concated [^Map m] - (let [val-list (java.util.LinkedList.) - it (.iterator (.entrySet m))] - (loop [] - (when (.hasNext it) - (do (let [^java.util.Map$Entry e (.next it) - fact (.fact ^FactWrapper (.getKey e)) - ^Iterable facts-in-val (.getValue e) - fact-iter (.iterator facts-in-val)] - (loop [] - (when (.hasNext fact-iter) - (do - (.add val-list (.next fact-iter)) - (recur))))) - (recur)))) - ;; This list will never be exposed to the user; it is simply iterated over - ;; by the engine and then discarded. This being the case there is no - ;; need to return a persistent data structure rather than an unmodifiable one. - (Collections/unmodifiableList val-list))) + (hf/apply-concat (hm/values m))) ;;; This is a pending updates cache that allows ;; retractions and insertions of equal facts diff --git a/src/main/clojure/clara/rules/update_cache/core.cljc b/src/main/clojure/clara/rules/update_cache/core.clj similarity index 65% rename from src/main/clojure/clara/rules/update_cache/core.cljc rename to src/main/clojure/clara/rules/update_cache/core.clj index 80073ea6..3849e876 100644 --- a/src/main/clojure/clara/rules/update_cache/core.cljc +++ b/src/main/clojure/clara/rules/update_cache/core.clj @@ -1,4 +1,6 @@ -(ns clara.rules.update-cache.core) +(ns clara.rules.update-cache.core + (:require [ham-fisted.api :as hf]) + (:import [ham_fisted MutList])) ;; Record indicating pending insertion or removal of a sequence of facts. (defrecord PendingUpdate [type facts]) @@ -12,21 +14,20 @@ ;; This cache replicates the behavior prior to https://github.com/cerner/clara-rules/issues/249, ;; just in a stateful object rather than a persistent data structure. -(deftype OrderedUpdateCache [updates] - +(deftype OrderedUpdateCache [^MutList ^:unsynchronized-mutable updates] UpdateCache (add-insertions! [this facts] - (swap! updates into [(->PendingUpdate :insert facts)])) + (.add updates (->PendingUpdate :insert facts))) (add-retractions! [this facts] - (swap! updates into [(->PendingUpdate :retract facts)])) + (.add updates (->PendingUpdate :retract facts))) (get-updates-and-reset! [this] - (let [current-updates @updates] - (reset! updates []) + (let [current-updates (hf/persistent! updates)] + (set! updates (hf/mut-list)) (partition-by :type current-updates)))) (defn get-ordered-update-cache [] - (OrderedUpdateCache. (atom []))) + (OrderedUpdateCache. (hf/mut-list))) diff --git a/src/main/clojure/clara/tools/fact_graph.cljc b/src/main/clojure/clara/tools/fact_graph.clj similarity index 96% rename from src/main/clojure/clara/tools/fact_graph.cljc rename to src/main/clojure/clara/tools/fact_graph.clj index 6fb04398..dacc7455 100644 --- a/src/main/clojure/clara/tools/fact_graph.cljc +++ b/src/main/clojure/clara/tools/fact_graph.clj @@ -33,12 +33,12 @@ (comp (remove :facts-accumulated) (map :fact)) (:matches explanation)) - + activation-node (map->RuleActivationNode {:rule-name rule-name :id (swap! id-counter inc)}) accum-matches (filter :facts-accumulated (:matches explanation))] - + (as-> original-graph graph (if (seq accum-matches) (reduce (fn [reduce-graph accum-match] @@ -64,8 +64,8 @@ (defn session->fact-graph "Given a session, return a graph structure connecting all facts to the facts - that they caused to be logically inserted. Note that such connections will not - be made for unconditionally inserted facts." + that they caused to be logically inserted. Note that such connections will not + be made for unconditionally inserted facts." [session] (let [id-counter (atom 0) ;; Use a counter, whose value will be added to internal nodes, to the ensure that @@ -78,7 +78,7 @@ ;; here without the performance penalty of generating all of the inspection data for the session. Therefore, for now ;; we break the privacy of the function here. Once issue 286 is completed we should remove this private Var access. fact->explanations (@#'i/gen-fact->explanations session) - + ;; Produce tuples of the form [inserted-fact {:rule rule :explanation clara.tools.inspect.Explanation}] insertion-tuples (into [] (comp @@ -89,7 +89,7 @@ v))) cat) fact->explanations)] - + (reduce (fn [graph tuple] (apply add-insertion-to-graph graph id-counter tuple)) empty-fact-graph diff --git a/src/main/clojure/clara/tools/inspect.cljc b/src/main/clojure/clara/tools/inspect.clj similarity index 58% rename from src/main/clojure/clara/tools/inspect.cljc rename to src/main/clojure/clara/tools/inspect.clj index 94b40180..b2831863 100644 --- a/src/main/clojure/clara/tools/inspect.cljc +++ b/src/main/clojure/clara/tools/inspect.clj @@ -1,57 +1,48 @@ (ns clara.tools.inspect "Tooling to inspect a rule session. The two major methods here are: - * inspect, which returns a data structure describing the session that can be used by tooling. - * explain-activations, which uses inspect and prints a human-readable description covering - why each rule activation or query match occurred." - (:require #?(:clj [clara.rules.engine :as eng]) - #?(:cljs [clara.rules.engine :as eng :refer [RootJoinNode - HashJoinNode - ExpressionJoinNode - NegationNode - NegationWithJoinFilterNode - ProductionNode]]) - [clara.rules.schema :as schema] - [clara.rules.memory :as mem] - [clara.tools.internal.inspect :as i] - #?(:cljs [goog.string :as gstr]) - #?(:clj - [clojure.main :refer [demunge]]) - [schema.core :as s] - [clojure.string :as str]) - #?(:clj - (:import [clara.rules.engine - ProductionNode - RootJoinNode - HashJoinNode - ExpressionJoinNode - NegationNode - NegationWithJoinFilterNode]))) + * inspect, which returns a data structure describing the session that can be used by tooling. + * explain-activations, which uses inspect and prints a human-readable description covering + why each rule activation or query match occurred." + (:require [clara.rules.engine :as eng] + [clara.rules.schema :as schema] + [clara.rules.memory :as mem] + [clara.tools.internal.inspect :as i] + [clojure.main :refer [demunge]] + [schema.core :as s] + [clojure.string :as str]) + (:import [clara.rules.engine + ProductionNode + RootJoinNode + HashJoinNode + ExpressionJoinNode + NegationNode + NegationWithJoinFilterNode])) (s/defschema ConditionMatch "A structure associating a condition with the facts that matched them. The fields are: - :fact - A fact propagated from this condition in a rule or query. For non-accumulator conditions, - this will be the fact matched by the condition. For accumulator conditions, it will be the result - of the accumulation. So, for example, if we have a condition like + :fact - A fact propagated from this condition in a rule or query. For non-accumulator conditions, + this will be the fact matched by the condition. For accumulator conditions, it will be the result + of the accumulation. So, for example, if we have a condition like - [?cold <- Cold] + [?cold <- Cold] - a ConditionMatch for this condition will have a Cold fact in its :fact field. If we have a condition like + a ConditionMatch for this condition will have a Cold fact in its :fact field. If we have a condition like - [?min-cold <- (acc/min :temperature) :from [Cold]] - - the value of :fact will be the minimum temperature returned by the accumulator. + [?min-cold <- (acc/min :temperature) :from [Cold]] - :condition - A structure representing this condition. This is the same structure used inside the structures defining - rules and queries. + the value of :fact will be the minimum temperature returned by the accumulator. - :facts-accumulated (nullable) : When the condition is an accumulator condition, this will contain the individual facts over - which the accumulator ran. For example, in the case above with the condition + :condition - A structure representing this condition. This is the same structure used inside the structures defining + rules and queries. - [?min-cold <- (acc/min :temperature) :from [Cold]] - - this will contain the individual Cold facts over which we accumulated, while the :fact field - will contain the result of the accumulation." + :facts-accumulated (nullable) : When the condition is an accumulator condition, this will contain the individual facts over + which the accumulator ran. For example, in the case above with the condition + + [?min-cold <- (acc/min :temperature) :from [Cold]] + + this will contain the individual Cold facts over which we accumulated, while the :fact field + will contain the result of the accumulation." {:fact s/Any :condition schema/Condition (s/optional-key :facts-accumulated) [s/Any]}) @@ -96,11 +87,11 @@ :join [condition] - ;; Negation nodes store the fact that they are a negation - ;; in their :node-type and strip the information out of the - ;; :condition field. We reconstruct the negation boolean condition - ;; that is contained in rule and query data structures created by defrule - ;; and that conforms to the Condition schema. + ;; Negation nodes store the fact that they are a negation + ;; in their :node-type and strip the information out of the + ;; :condition field. We reconstruct the negation boolean condition + ;; that is contained in rule and query data structures created by defrule + ;; and that conforms to the Condition schema. :negation [[:not condition]]) concat (map :fact (mem/get-elements-all memory {:id node-id})))) @@ -115,7 +106,7 @@ (for [{:keys [matches bindings] :as token} tokens] (->Explanation - ;; Convert matches to explanation structure. + ;; Convert matches to explanation structure. (for [[fact node-id] matches :let [node (id-to-node node-id) condition (if (:accum-condition node) @@ -135,10 +126,9 @@ {:fact fact :condition condition})) - ;; Remove generated bindings from user-facing explanation. + ;; Remove generated bindings from user-facing explanation. (into {} (remove (fn [[k v]] - #?(:clj (.startsWith (name k) "?__gen__")) - #?(:cljs (gstr/startsWith (name k) "?__gen__"))) + (.startsWith (name k) "?__gen__")) bindings)))))) (defn ^:private gen-all-rule-matches @@ -150,14 +140,14 @@ [(:production k) (to-explanations session (map #(-> % :activation :token) v))])) grouped-info)))) - + (defn ^:private gen-fact->explanations [session] (let [{:keys [memory rulebase]} (eng/components session) {:keys [productions production-nodes query-nodes]} rulebase rule-to-rule-node (into {} (for [rule-node production-nodes] - [(:production rule-node) rule-node]))] + [(:production rule-node) rule-node]))] (apply merge-with into (for [[rule rule-node] rule-to-rule-node token (keys (mem/get-insertions-all memory rule-node)) @@ -167,54 +157,54 @@ :explanation (first (to-explanations session [token]))}]})))) (def ^{:doc "Return a new session on which information will be gathered for optional inspection keys. - This can significantly increase memory consumption since retracted facts - cannot be garbage collected as normally."} + This can significantly increase memory consumption since retracted facts + cannot be garbage collected as normally."} with-full-logging i/with-activation-listening) (def ^{:doc "Return a new session without information gathering on this session for optional inspection keys. - This new session will not retain references to any such information previously gathered."} + This new session will not retain references to any such information previously gathered."} without-full-logging i/without-activation-listening) - + (s/defn inspect " Returns a representation of the given rule session useful to understand the - state of the underlying rules. + state of the underlying rules. + + The returned structure always includes the following keys: - The returned structure always includes the following keys: + * :rule-matches -- a map of rule structures to their matching explanations. + Note that this only includes rule matches with corresponding logical + insertions after the rules finished firing. + * :query-matches -- a map of query structures to their matching explanations. + * :condition-matches -- a map of conditions pulled from each rule to facts they match. + * :insertions -- a map of rules to a sequence of {:explanation E, :fact F} records + to allow inspection of why a given fact was inserted. + * :fact->explanations -- a map of facts inserted to a sequence + of maps of the form {:rule rule-structure :explanation explanation}, + where each such map justifies a single insertion of the fact. - * :rule-matches -- a map of rule structures to their matching explanations. - Note that this only includes rule matches with corresponding logical - insertions after the rules finished firing. - * :query-matches -- a map of query structures to their matching explanations. - * :condition-matches -- a map of conditions pulled from each rule to facts they match. - * :insertions -- a map of rules to a sequence of {:explanation E, :fact F} records - to allow inspection of why a given fact was inserted. - * :fact->explanations -- a map of facts inserted to a sequence - of maps of the form {:rule rule-structure :explanation explanation}, - where each such map justifies a single insertion of the fact. + And additionally includes the following keys for operations + performed after a with-full-logging call on the session: - And additionally includes the following keys for operations - performed after a with-full-logging call on the session: - - * :unfiltered-rule-matches: A map of rule structures to their matching explanations. - This includes all rule activations, regardless of whether they led to insertions or if - they were ultimately retracted. This should be considered low-level information primarily - useful for debugging purposes rather than application control logic, although legitimate use-cases - for the latter do exist if care is taken. Patterns of insertion and retraction prior to returning to - the caller are internal implementation details of Clara unless explicitly controlled by the user. + * :unfiltered-rule-matches: A map of rule structures to their matching explanations. + This includes all rule activations, regardless of whether they led to insertions or if + they were ultimately retracted. This should be considered low-level information primarily + useful for debugging purposes rather than application control logic, although legitimate use-cases + for the latter do exist if care is taken. Patterns of insertion and retraction prior to returning to + the caller are internal implementation details of Clara unless explicitly controlled by the user. - Users may inspect the entire structure for troubleshooting or explore it - for specific cases. For instance, the following code snippet could look - at all matches for some example rule: + Users may inspect the entire structure for troubleshooting or explore it + for specific cases. For instance, the following code snippet could look + at all matches for some example rule: - (defrule example-rule ... ) + (defrule example-rule ... ) - ... + ... - (get-in (inspect example-session) [:rule-matches example-rule]) + (get-in (inspect example-session) [:rule-matches example-rule]) - ... + ... - The above segment will return matches for the rule in question." + The above segment will return matches for the rule in question." [session] :- InspectionSchema (let [{:keys [memory rulebase]} (eng/components session) {:keys [productions production-nodes query-nodes id-to-node]} rulebase @@ -257,27 +247,27 @@ "Prints a human-readable explanation of the facts and conditions that created the Rete token." ([explanation] (explain-activation explanation "")) ([explanation prefix] - (doseq [{:keys [fact condition]} (:matches explanation)] - (if (:from condition) - ;; Explain why the accumulator matched. - (let [{:keys [accumulator from]} condition] - (println prefix fact) - (println prefix " accumulated with" accumulator) - (println prefix " from" (:type from)) - (println prefix " where" (:constraints from))) - - ;; Explain why a condition matched. - (let [{:keys [type constraints]} condition] - (println prefix fact) - (println prefix " is a" type) - (println prefix " where" constraints)))))) + (doseq [{:keys [fact condition]} (:matches explanation)] + (if (:from condition) + ;; Explain why the accumulator matched. + (let [{:keys [accumulator from]} condition] + (println prefix fact) + (println prefix " accumulated with" accumulator) + (println prefix " from" (:type from)) + (println prefix " where" (:constraints from))) + + ;; Explain why a condition matched. + (let [{:keys [type constraints]} condition] + (println prefix fact) + (println prefix " is a" type) + (println prefix " where" constraints)))))) (defn explain-activations "Prints a human-friendly explanation of why rules and queries matched in the given session. A caller my optionally pass a :rule-filter-fn, which is a predicate (clara.tools.inspect/explain-activations session - :rule-filter-fn (fn [rule] (re-find my-rule-regex (:name rule))))" + :rule-filter-fn (fn [rule] (re-find my-rule-regex (:name rule))))" [session & {:keys [rule-filter-fn] :as options}] (let [filter-fn (or rule-filter-fn (constantly true))] @@ -311,24 +301,23 @@ (defn node-fn-name->production-name "A helper function for retrieving the name or names of rules that a generated function belongs to. - 'session' - a LocalSession from which a function was retrieved - 'node-fn' - supports the following types: - 1. String - expected to be in the format '/__'. - Expected use-case for string would be in the event that a user copy pasted this function identifier - from an external tool, ex. a jvm profiler - 2. Symbol - expected to be in the format '/__. - Has the same use-case as string, just adds flexibility to the type. - 3. Function - expected to be the actual function from the Session - This covers a use-case where the user can capture the function being used and programmatically - trace it back to the rules being executed." + 'session' - a LocalSession from which a function was retrieved + 'node-fn' - supports the following types: + 1. String - expected to be in the format '/__'. + Expected use-case for string would be in the event that a user copy pasted this function identifier + from an external tool, ex. a jvm profiler + 2. Symbol - expected to be in the format '/__. + Has the same use-case as string, just adds flexibility to the type. + 3. Function - expected to be the actual function from the Session + This covers a use-case where the user can capture the function being used and programmatically + trace it back to the rules being executed." [session node-fn] (let [fn-name-str (cond (string? node-fn) node-fn (fn? node-fn) - #?(:clj (str node-fn) - :cljs (.-name node-fn) ) + (str node-fn) (symbol? node-fn) (str node-fn) @@ -339,12 +328,9 @@ :supported-types ["string" "symbol" "fn"]}))) fn-name-str (-> fn-name-str demunge (str/split #"/") last) - simple-fn-name #?(:clj - (-> (or (re-find #"(.+)--\d+" fn-name-str) ;; anonymous function - (re-find #"(.+)" fn-name-str)) ;; regular function - last) - :cljs - fn-name-str) + simple-fn-name (-> (or (re-find #"(.+)--\d+" fn-name-str) ;; anonymous function + (re-find #"(.+)" fn-name-str)) ;; regular function + last) [node-abr node-id _] (str/split simple-fn-name #"-")] ;; used as a sanity check that the fn provided is in the form expected, ie. -- @@ -352,8 +338,7 @@ (if-let [node (-> (eng/components session) :rulebase :id-to-node - (get #?(:clj (Long/valueOf ^String node-id) - :cljs (js/parseInt node-id))))] + (get (Long/valueOf ^String node-id)))] (if (= ProductionNode (type node)) [(-> node :production :name)] (if-let [production-names (seq (eng/node-rule-names (some-fn :production :query) node))] diff --git a/src/main/clojure/clara/tools/internal/inspect.cljc b/src/main/clojure/clara/tools/internal/inspect.clj similarity index 99% rename from src/main/clojure/clara/tools/internal/inspect.cljc rename to src/main/clojure/clara/tools/internal/inspect.clj index 35695fd9..a6b33498 100644 --- a/src/main/clojure/clara/tools/internal/inspect.cljc +++ b/src/main/clojure/clara/tools/internal/inspect.clj @@ -77,4 +77,4 @@ (throw (ex-info "Found more than one PersistentActivationListener on session" {:session session}))))) - + diff --git a/src/main/clojure/clara/tools/loop_detector.cljc b/src/main/clojure/clara/tools/loop_detector.clj similarity index 76% rename from src/main/clojure/clara/tools/loop_detector.cljc rename to src/main/clojure/clara/tools/loop_detector.clj index dfe71476..970d0dda 100644 --- a/src/main/clojure/clara/tools/loop_detector.cljc +++ b/src/main/clojure/clara/tools/loop_detector.clj @@ -1,12 +1,13 @@ (ns clara.tools.loop-detector (:require [clara.rules.listener :as l] [clara.rules.engine :as eng] - [clara.tools.tracing :as trace])) + [clara.tools.tracing :as trace]) + (:import [clojure.lang IDeref])) ;; Although we use a single type here note that the cycles-count and the on-limit-delay fields ;; will be nil during the persistent state of the listener. (deftype CyclicalRuleListener [cycles-count max-cycles on-limit-fn on-limit-delay] - l/ITransientEventListener + l/ITransientEventListener (left-activate! [listener node tokens] listener) (left-retract! [listener node tokens] @@ -44,7 +45,9 @@ @on-limit-delay) (swap! cycles-count inc)) (to-persistent! [listener] - (CyclicalRuleListener. nil max-cycles on-limit-fn nil)) + (CyclicalRuleListener. (if (instance? IDeref cycles-count) + (deref cycles-count) + cycles-count) max-cycles on-limit-fn nil)) l/IPersistentEventListener (to-transient [listener] @@ -74,22 +77,21 @@ (ifn? fn-or-keyword) fn-or-keyword :else (throw (ex-info "The :on-error-fn must be a non-nil function value" {:clara-rules/max-cycles-exceeded-fn fn-or-keyword})))) - (defn with-loop-detection - "Detect suspected infinite loops in the session. + "Detect suspected infinite loops in the session. - Max-cycles is the maximum - number of transitions permitted between different activation groups (salience levels) - plus the number of times all rules are evaluated and their facts inserted, thus leading - to another cycle of rules activations in the same activation group. + Max-cycles is the maximum + number of transitions permitted between different activation groups (salience levels) + plus the number of times all rules are evaluated and their facts inserted, thus leading + to another cycle of rules activations in the same activation group. - on-limit-fn is a 0-arg function that is invoked exactly once when this limit is exceeded. It can either be - a user-provided function or a keyword that indicates a built-in function to use. Currently supported keywords are: + on-limit-fn is a 0-arg function that is invoked exactly once when this limit is exceeded. It can either be + a user-provided function or a keyword that indicates a built-in function to use. Currently supported keywords are: - :throw-exception - This throws an exception when the limit is reached. If tracing is enabled, the exception will include - the trace. + :throw-exception - This throws an exception when the limit is reached. If tracing is enabled, the exception will include + the trace. - :standard-out-warning - This prints a warning to standard out." + :standard-out-warning - This prints a warning to standard out." [session max-cycles on-limit-fn] diff --git a/src/main/clojure/clara/tools/testing_utils.clj b/src/main/clojure/clara/tools/testing_utils.clj new file mode 100644 index 00000000..ac13c1d8 --- /dev/null +++ b/src/main/clojure/clara/tools/testing_utils.clj @@ -0,0 +1,248 @@ +(ns clara.tools.testing-utils + "Internal utilities for testing clara-rules and derivative projects. These should be considered experimental + right now from the perspective of consumers of clara-rules, although it is possible that this namespace + will be made part of the public API once its functionality has proven robust and reliable. The focus, however, + is functionality needed to test the rules engine itself." + (:require [clara.rules.update-cache.core :as uc] + [clara.rules.update-cache.cancelling :as ca] + [clara.rules.compiler :as com] + [clara.rules.dsl :as dsl] + [clara.rules :as r] + [clojure.test :refer [is]] + [futurama.core :refer [async !rule (->> params + :rules + (partition 2) + (into {} + (map (fn [[rule-name [lhs rhs props]]] + [rule-name (assoc (dsl/parse-rule* lhs rhs props &env (meta &form)) :name (str rule-name))])))) + + sym->query (->> params + :queries + (partition 2) + (into {} + (map (fn [[query-name [params lhs]]] + [query-name (assoc (dsl/parse-query* params lhs &env (meta &form)) :name (str query-name))])))) + + production-syms->productions (fn [p-syms] + (map (fn [s] + (or (get sym->rule s) + (get sym->query s))) + p-syms)) + + session-syms->session-forms (->> params + :sessions + (partition 3) + (into [] + (comp (map (fn [[session-name production-syms session-opts]] + [session-name (production-syms->productions production-syms) session-opts])) + (map (fn [[session-name productions session-opts]] + [session-name `(com/mk-session ~(into [(vec productions)] + cat + session-opts))])) + cat))) + + test-form `(clojure.test/deftest + ~name + (let [~@session-syms->session-forms + ~@(sequence cat sym->query) + ~@(sequence cat sym->rule)] + ~@forms))] + test-form)) + +(defn test-compile-async-action + "Compile the right-hand-side action of a rule as an async action for testing" + [node-id binding-keys rhs env] + (let [rhs-bindings-used (com/variables-as-keywords rhs) + + token-binding-keys (sequence + (filter rhs-bindings-used) + 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-action' to be used for this scenario + fn-name (com/mk-node-fn-name "ProductionNode" node-id "AE")] + `(fn ~fn-name [~'?__token__ ~destructured-env] + ;; similar to test nodes, nothing in the contract of an RHS enforces that bound variables must be used. + ;; similarly we will not bind anything in this event, and thus the let block would be superfluous. + (async + ~(if (seq token-binding-keys) + `(let [{:keys [~@(map (comp symbol name) token-binding-keys)]} (:bindings ~'?__token__)] + ~rhs) + rhs))))) + +(defn test-fire-rules-async + ([session] + (test-fire-rules-async session {})) + ([session opts] + (! + (into [] + (comp + (map #(- % mean)) + (map #(Math/pow (double %) 2.0))) + execution-times) + sum + (/ iterations) + Math/sqrt)] + {:std (double std) + :mean (double mean)})) + +(defn run-performance-test + "Created as a rudimentary alternative to criterium, due to assumptions made during benchmarking. Specifically, that + criterium attempts to reach a steady state of compiled and loaded classes. This fundamentally doesn't work when the + metrics needed rely on compilation or evaluation." + [form] + (let [{:keys [description func iterations mean-assertion verbose]} form + {:keys [std mean]} (execute-tests func iterations)] + (when verbose + (println (str \newline "Running Performance tests for:")) + (println description) + (println "==========================================") + (println (str "Mean: " mean "ms")) + (println (str "Standard Deviation: " std "ms" \newline))) + (is (mean-assertion mean) + (str "Actual mean value: " mean)) + {:mean mean + :std std})) + +(defn ex-data-search + ([^Exception e edata] + (ex-data-search e nil edata)) + ([^Exception e emsg edata] + (loop [non-matches [] + e e] + (cond + ;; Found match. + (and (= edata + (select-keys (ex-data e) + (keys edata))) + (or (= emsg + (.getMessage e)) + (nil? emsg))) + :success + + ;; Keep searching, record any non-matching ex-data. + (.getCause e) + (recur (if-let [ed (ex-data e)] + (conj non-matches {(.getMessage e) ed}) + non-matches) + (.getCause e)) + + ;; Can't find a match. + :else + non-matches)))) + +(defn get-all-ex-data + "Walk a Throwable chain and return a sequence of all data maps + from any ExceptionInfo instances in that chain." + [e] + (let [get-ex-chain (fn get-ex-chain [e] + (if-let [cause (.getCause e)] + (conj (get-ex-chain cause) e) + [e]))] + + (map ex-data + (filter (partial instance? clojure.lang.IExceptionInfo) + (get-ex-chain e))))) + +(defmacro assert-ex-data + ([expected-ex-data form] + `(assert-ex-data nil ~expected-ex-data ~form)) + ([expected-ex-message expected-ex-data form] + `(try + ~form + (is false + (str "Exception expected to be thrown when evaluating: " \newline + '~form)) + (catch Exception e# + (let [res# (ex-data-search e# ~expected-ex-message ~expected-ex-data)] + (is (= :success res#) + (str "Exception msg found: " \newline + e# \newline + "Non matches found: " \newline + res#))))))) + +(defn ex-data-maps + "Given a throwable/exception/error `t`, return all `ex-data` maps from the stack trace cause chain in + the order they occur traversing the chain from this `t` through the rest of the call stack." + [t] + (let [append-self (fn append-self + [prior t1] + (if t1 + (append-self (conj prior t1) (.getCause ^Throwable t1)) + prior)) + throwables (append-self [] t)] + (into [] + (comp (map ex-data)) + throwables))) diff --git a/src/main/clojure/clara/tools/testing_utils.cljc b/src/main/clojure/clara/tools/testing_utils.cljc deleted file mode 100644 index fc2e890f..00000000 --- a/src/main/clojure/clara/tools/testing_utils.cljc +++ /dev/null @@ -1,229 +0,0 @@ -#?(:clj - (ns clara.tools.testing-utils - "Internal utilities for testing clara-rules and derivative projects. These should be considered experimental - right now from the perspective of consumers of clara-rules, although it is possible that this namespace - will be made part of the public API once its functionality has proven robust and reliable. The focus, however, - is functionality needed to test the rules engine itself." - (:require [clara.rules.update-cache.core :as uc] - [clara.rules.update-cache.cancelling :as ca] - [clara.rules.compiler :as com] - [clara.macros :as m] - [clara.rules.dsl :as dsl] - [clojure.test :refer [is]])) - :cljs - (ns clara.tools.testing-utils - (:require [clara.rules.update-cache.core :as uc]) - (:require-macros [clara.tools.testing-utils] - [cljs.test :refer [is]]))) - -#?(:clj - (defmacro def-rules-test - "This macro allows creation of rules, queries, and sessions from arbitrary combinations of rules - and queries in a setup map without the necessity of creating a namespace or defining a session - using defsession in both Clojure and ClojureScript. The first argument is the name of the test, - and the second argument is a map with entries :rules, :queries, and :sessions. For example usage see - clara.test-testing-utils. Note that sessions currently can only contain rules and queries defined - in the setup map; supporting other rule sources such as namespaces and defrule/defquery may be possible - in the future. - - Namespaces consuming this macro are expected to require clara.rules and either clojure.test or cljs.test. - Unfortunately, at this time we can't add inline requires for these namespace with the macroexpanded code in - ClojureScript; see https://anmonteiro.com/2016/10/clojurescript-require-outside-ns/ for some discussion on the - subject. However, the test namespaces consuming this will in all likelihood have these dependencies anyway - so this probably isn't a significant shortcoming of this macro." - [name params & forms] - (let [sym->rule (->> params - :rules - (partition 2) - (into {} - (map (fn [[rule-name [lhs rhs props]]] - [rule-name (assoc (dsl/parse-rule* lhs rhs props {}) :name (str rule-name))])))) - - sym->query (->> params - :queries - (partition 2) - (into {} - (map (fn [[query-name [params lhs]]] - [query-name (assoc (dsl/parse-query* params lhs {}) :name (str query-name))])))) - - production-syms->productions (fn [p-syms] - (map (fn [s] - (or (get sym->rule s) - (get sym->query s))) - p-syms)) - - session-syms->session-forms (->> params - :sessions - (partition 3) - (into [] - (comp (map (fn [[session-name production-syms session-opts]] - [session-name (production-syms->productions production-syms) session-opts])) - (map (fn [[session-name productions session-opts]] - [session-name (if (com/compiling-cljs?) - (m/productions->session-assembly-form (map eval productions) session-opts) - `(com/mk-session ~(into [(vec productions)] - cat - session-opts)))])) - cat))) - - test-form `(~(if (com/compiling-cljs?) - 'cljs.test/deftest - 'clojure.test/deftest) - ~name - (let [~@session-syms->session-forms - ~@(sequence cat sym->query) - ~@(sequence cat sym->rule)] - ~@forms))] - test-form))) - -#?(:clj - (defn opts-fixture - ;; For operations other than replace-facts uc/get-ordered-update-cache is currently - ;; always used. This fixture ensures that CancellingUpdateCache is tested for a wide - ;; variety of different cases rather than a few cases cases specific to it. - [f] - (f) - (with-redefs [uc/get-ordered-update-cache ca/get-cancelling-update-cache] - (f)))) - -(defn join-filter-equals - "Intended to be a test function that is the same as equals, but is not visible to Clara as such - and thus forces usage of join filters instead of hash joins" - [& args] - (apply = args)) - -(def side-effect-holder (atom nil)) - -(defn side-effect-holder-fixture - "Fixture to reset the side effect holder to nil both before and after tests. - This should be used as a :each fixture." - [t] - (reset! side-effect-holder nil) - (t) - (reset! side-effect-holder nil)) - -#?(:clj - (defn time-execution - [func] - (let [start (System/currentTimeMillis) - _ (func) - stop (System/currentTimeMillis)] - (- stop start))) - :cljs - (defn time-execution - [func] - (let [start (.getTime (js/Date.)) - _ (func) - stop (.getTime (js/Date.))] - (- stop start)))) - -(defn execute-tests - [func iterations] - (let [execution-times (for [_ (range iterations)] - (time-execution func)) - sum #(reduce + %) - mean (/ (sum execution-times) iterations) - std (-> - (into [] - (comp - (map #(- % mean)) - (map #(Math/pow (double %) 2.0))) - execution-times) - sum - (/ iterations) - Math/sqrt)] - {:std (double std) - :mean (double mean)})) - -(defn run-performance-test - "Created as a rudimentary alternative to criterium, due to assumptions made during benchmarking. Specifically, that - criterium attempts to reach a steady state of compiled and loaded classes. This fundamentally doesn't work when the - metrics needed rely on compilation or evaluation." - [form] - (let [{:keys [description func iterations mean-assertion verbose]} form - {:keys [std mean]} (execute-tests func iterations)] - (when verbose - (println (str \newline "Running Performance tests for:")) - (println description) - (println "==========================================") - (println (str "Mean: " mean "ms")) - (println (str "Standard Deviation: " std "ms" \newline))) - (is (mean-assertion mean) - (str "Actual mean value: " mean)) - {:mean mean - :std std})) - -#?(:clj - (defn ex-data-search - ([^Exception e edata] - (ex-data-search e nil edata)) - ([^Exception e emsg edata] - (loop [non-matches [] - e e] - (cond - ;; Found match. - (and (= edata - (select-keys (ex-data e) - (keys edata))) - (or (= emsg - (.getMessage e)) - (nil? emsg))) - :success - - ;; Keep searching, record any non-matching ex-data. - (.getCause e) - (recur (if-let [ed (ex-data e)] - (conj non-matches {(.getMessage e) ed}) - non-matches) - (.getCause e)) - - ;; Can't find a match. - :else - non-matches))))) - -#?(:clj - (defn get-all-ex-data - "Walk a Throwable chain and return a sequence of all data maps - from any ExceptionInfo instances in that chain." - [e] - (let [get-ex-chain (fn get-ex-chain [e] - (if-let [cause (.getCause e)] - (conj (get-ex-chain cause) e) - [e]))] - - (map ex-data - (filter (partial instance? clojure.lang.IExceptionInfo) - (get-ex-chain e)))))) - -#?(:clj - (defmacro assert-ex-data - ([expected-ex-data form] - `(assert-ex-data nil ~expected-ex-data ~form)) - ([expected-ex-message expected-ex-data form] - `(try - ~form - (is false - (str "Exception expected to be thrown when evaluating: " \newline - '~form)) - (catch Exception e# - (let [res# (ex-data-search e# ~expected-ex-message ~expected-ex-data)] - (is (= :success res#) - (str "Exception msg found: " \newline - e# \newline - "Non matches found: " \newline - res#)))))))) - -#?(:clj - (defn ex-data-maps - "Given a throwable/exception/error `t`, return all `ex-data` maps from the stack trace cause chain in - the order they occur traversing the chain from this `t` through the rest of the call stack." - [t] - (let [append-self (fn append-self - [prior t1] - (if t1 - (append-self (conj prior t1) (.getCause ^Throwable t1)) - prior)) - throwables (append-self [] t)] - (into [] - (comp (map ex-data)) - throwables)))) diff --git a/src/main/clojure/clara/tools/tracing.cljc b/src/main/clojure/clara/tools/tracing.clj similarity index 99% rename from src/main/clojure/clara/tools/tracing.cljc rename to src/main/clojure/clara/tools/tracing.clj index a9d5ffe7..4cc6d955 100644 --- a/src/main/clojure/clara/tools/tracing.cljc +++ b/src/main/clojure/clara/tools/tracing.clj @@ -28,7 +28,7 @@ (insert-facts! [listener node token facts] (append-trace listener {:type :add-facts :node node :token token :facts facts})) - + (alpha-activate! [listener node facts] (append-trace listener {:type :alpha-activate :facts facts})) @@ -37,7 +37,7 @@ (retract-facts! [listener node token facts] (append-trace listener {:type :retract-facts :node node :token token :facts facts})) - + (alpha-retract! [listener node facts] (append-trace listener {:type :alpha-retract :facts facts})) @@ -129,7 +129,6 @@ (when tracing-listener (.-trace ^PersistentTracingListener tracing-listener)))) - (defn ^:private node-id->productions "Given a session and a node ID return a list of the rule and query names associated with the node." diff --git a/src/main/java/clara/rules/package-info.java b/src/main/java/clara/rules/package-info.java index 024f91b3..352a2b40 100644 --- a/src/main/java/clara/rules/package-info.java +++ b/src/main/java/clara/rules/package-info.java @@ -14,7 +14,7 @@ * since the WorkingMemory is immutable, creating a new instance that shares internal state when changes occur. *

* - * See the Clara Examples + * See the Clara Examples * project for an example of this in action. */ package clara.rules; diff --git a/src/test/clojure/clara/coverage_ruleset.clj b/src/test/clojure/clara/coverage_ruleset.clj new file mode 100644 index 00000000..ede4bba9 --- /dev/null +++ b/src/test/clojure/clara/coverage_ruleset.clj @@ -0,0 +1,14 @@ +(ns clara.coverage-ruleset + (:require [clara.rules :refer [defrule defquery insert!]])) + +(defrule simple-rule-with-rhs + [:weather [{:keys [temperature]}] + (= temperature ?temperature)] + => + (if (< ?temperature 50) + (insert! {:type :climate :label "Cold"}) + (insert! {:type :climate :label "Warm"}))) + +(defquery climate-query + [] + [?result <- :climate]) diff --git a/src/test/clojure/clara/generative/generators.clj b/src/test/clojure/clara/generative/generators.clj index cb3d2486..a8ecb9e8 100644 --- a/src/test/clojure/clara/generative/generators.clj +++ b/src/test/clojure/clara/generative/generators.clj @@ -4,13 +4,13 @@ [schema.core :as s])) (s/defschema FactSessionOperation {:type (s/enum :insert :retract) - :facts [s/Any]}) + :facts [s/Any]}) (s/defschema FireSessionOperation {:type (s/enum :fire)}) (s/defschema SessionOperation (s/conditional - #(= (:type %) :fire) FireSessionOperation - :else FactSessionOperation)) + #(= (:type %) :fire) FireSessionOperation + :else FactSessionOperation)) (defn session-run-ops "Run the provided sequence of operations on the provide session and return the final session." @@ -38,7 +38,7 @@ any-count-negative? (fn [fc] (boolean (some neg? (vals fc))))] - + (= ::premature-retract (reduce (fn [fact-count op] (let [new-count (condp = (:type op) :insert (inc-fact-count fact-count (:facts op)) @@ -87,7 +87,7 @@ {:keys [dup-level] :or {dup-level 0}}] (let [dup-ops-seqs (ops->add-insert-retract ops dup-level) permutations (mapcat combo/permutations dup-ops-seqs)] - + ;; The permutation creation allows for a retraction to occur before insertion, which ;; effectively removes the retraction from the seq of operations since retractions of facts ;; that are not present do not cause alteration of the session state. The idea of these helpers @@ -99,4 +99,4 @@ ;; ;; For now, we can just find all permutations and remove the ones with invalid ordering. ;; This is inefficient and there may be a more efficient algorithm or implementation. - (remove retract-before-insertion? permutations))) + (remove retract-before-insertion? permutations))) diff --git a/src/test/clojure/clara/generative/test_accum.clj b/src/test/clojure/clara/generative/test_accum.clj index 66f48ef0..cda79545 100644 --- a/src/test/clojure/clara/generative/test_accum.clj +++ b/src/test/clojure/clara/generative/test_accum.clj @@ -15,7 +15,7 @@ (use-fixtures :once schema.test/validate-schemas) -(deftest test-simple-all-condition-binding-groups +(deftest ^:generative test-simple-all-condition-binding-groups (let [r (dsl/parse-rule [[?ts <- (acc/all) :from [Temperature (= ?loc location)]]] ;; The all accumulator can return facts in different orders, so we sort ;; the temperatures to make asserting on the output easier. @@ -50,7 +50,7 @@ expected-temp-hist (frequencies [{:?history (->TemperatureHistory ["MCI" [11 19]])} {:?history (->TemperatureHistory ["ORD" [1]])}])] (= actual-temp-hist expected-temp-hist)))] - + (doseq [permutation (map #(concat % [{:type :fire}]) operation-permutations) :let [session (gen/session-run-ops empty-session permutation)]] (is (expected-output? session permutation) @@ -75,7 +75,7 @@ (->Temperature 25 "LGA")]) operation-permutations (gen/ops->permutations operations {})] - + (doseq [permutation (map #(concat % [{:type :fire}]) operation-permutations) :let [session (gen/session-run-ops empty-session permutation) output (query session q)]] @@ -86,7 +86,7 @@ "Output was: " (into [] output))))))) -(deftest test-min-accum-with-binding-groups +(deftest ^:generative test-min-accum-with-binding-groups (let [coldest-rule (dsl/parse-rule [[?coldest-temp <- (acc/min :temperature :returns-fact true) :from [ColdAndWindy (= ?w windspeed)]]] (insert! (->Cold (:temperature ?coldest-temp)))) @@ -121,7 +121,7 @@ "The output was: " (into [] output)))))) -(deftest test-min-accum-without-binding-groups +(deftest ^:generative test-min-accum-without-binding-groups (let [coldest-rule (dsl/parse-rule [[?coldest <- (acc/min :temperature) :from [Cold]]] (insert! (->Temperature ?coldest "MCI"))) temp-query (dsl/parse-query [] [[Temperature (= ?t temperature)]]) @@ -147,7 +147,7 @@ :let [session (gen/session-run-ops empty-session permutation) output (query session temp-query)]] - + (is (= output [{:?t (min temp-1 temp-2)}]) (str "Did not find the correct minimum temperature for permutation: " diff --git a/src/test/clojure/clara/generative/test_generators.clj b/src/test/clojure/clara/generative/test_generators.clj index f28e48ae..41ab9f41 100644 --- a/src/test/clojure/clara/generative/test_generators.clj +++ b/src/test/clojure/clara/generative/test_generators.clj @@ -7,7 +7,7 @@ (use-fixtures :once schema.test/validate-schemas) ;; Basic sanity test of the insert/retract/fire permutation generation. -(deftest test-basic-permutations +(deftest ^:generative test-basic-permutations (let [base-ops [{:type :insert :facts [:a]}] permuted-ops (ops->permutations base-ops {:dup-level 1})] diff --git a/src/test/clojure/clara/long_running_tests.clj b/src/test/clojure/clara/long_running_tests.clj index d300c92e..09ba7376 100644 --- a/src/test/clojure/clara/long_running_tests.clj +++ b/src/test/clojure/clara/long_running_tests.clj @@ -22,7 +22,7 @@ ;; Validating that there were 5472 forms in the eval call. (is (= 5472 (count (-> e ex-data :compilation-ctxs)))) - (is (re-find #"method size exceeded" (.getMessage e))) + (is (re-find #"method size exceeded" (ex-message e))) ;; Validate that the stated 5471 forms per eval will compile - (is (sc/without-fn-validation (com/mk-session (conj (vector rules) :forms-per-eval 5471 :cache false)))))) \ No newline at end of file + (is (sc/without-fn-validation (com/mk-session (conj (vector rules) :forms-per-eval 5471 :cache false)))))) diff --git a/src/test/clojure/clara/other_ruleset.clj b/src/test/clojure/clara/other_ruleset.clj index a2de3e75..afabe846 100644 --- a/src/test/clojure/clara/other_ruleset.clj +++ b/src/test/clojure/clara/other_ruleset.clj @@ -23,7 +23,7 @@ (defquery temp-by-location "Query temperatures by location." [:?loc] - (Temperature (== ?temp temperature) + (Temperature (== ?temp temperature) (== ?loc location))) diff --git a/src/test/clojure/clara/performance/test_compilation.clj b/src/test/clojure/clara/performance/test_compilation.clj index 33ad4bed..803b614d 100644 --- a/src/test/clojure/clara/performance/test_compilation.clj +++ b/src/test/clojure/clara/performance/test_compilation.clj @@ -21,11 +21,11 @@ (for [seed-sym seed-syms :let [next-fact (symbol (str seed-sym "prime")) production (assoc base-production - :lhs [{:type (keyword seed-sym) - :constraints [`(= ~'this ~'?binding) `(filter-fn ~'this)]}] - :rhs `(r/insert! (with-meta ~(set (repeatedly 10 #(rand-nth (range 100)))) - {:type ~(keyword next-fact) - :val ~'?binding})))]] + :lhs [{:type (keyword seed-sym) + :constraints [`(= ~'this ~'?binding) `(filter-fn ~'this)]}] + :rhs `(r/insert! (with-meta ~(set (repeatedly 10 #(rand-nth (range 100)))) + {:type ~(keyword next-fact) + :val ~'?binding})))]] [next-fact production]))) (defn generate-compose-productions @@ -34,12 +34,12 @@ ([l] (template l l)) ([l r] (let [next-fact (symbol (str l r "prime")) production (assoc base-production - :lhs [{:type (keyword l) - :constraints [`(= ~'this ~'?binding-l)]} - {:type (keyword r) - :constraints [`(= ~'?binding-l ~'this)]}] - :rhs `(r/insert! (with-meta ~(set (repeatedly 10 #(rand-nth (range 100)))) - {:type ~(keyword next-fact)})))] + :lhs [{:type (keyword l) + :constraints [`(= ~'this ~'?binding-l)]} + {:type (keyword r) + :constraints [`(= ~'?binding-l ~'this)]}] + :rhs `(r/insert! (with-meta ~(set (repeatedly 10 #(rand-nth (range 100)))) + {:type ~(keyword next-fact)})))] [next-fact production])))] (into {} (for [combo (partition-all 2 (shuffle seed-syms))] @@ -51,12 +51,12 @@ (for [seed-sym seed-syms :let [next-fact (symbol (str seed-sym "prime")) production (assoc base-production - :lhs [{:accumulator `(acc/all) - :from {:type (keyword seed-sym), - :constraints [`(filter-fn ~'this)]} - :result-binding :?binding}] - :rhs `(r/insert! (with-meta ~'?binding - {:type ~(keyword next-fact)})))]] + :lhs [{:accumulator `(acc/all) + :from {:type (keyword seed-sym), + :constraints [`(filter-fn ~'this)]} + :result-binding :?binding}] + :rhs `(r/insert! (with-meta ~'?binding + {:type ~(keyword next-fact)})))]] [next-fact production]))) (defn generate-queries @@ -64,10 +64,10 @@ (into {} (for [seed-sym seed-syms :let [production (assoc base-production - :lhs [{:type (keyword seed-sym) - :constraints [] - :fact-binding :?binding}] - :params #{})]] + :lhs [{:type (keyword seed-sym) + :constraints [] + :fact-binding :?binding}] + :params #{})]] [seed-sym production]))) (defn generate-rules-and-opts @@ -91,31 +91,31 @@ (let [rules (generate-rules-and-opts 500)] (testing "Session creation performance" (utils/run-performance-test - {:description "Generated Session Compilation" - :func #(com/mk-session rules) - :iterations 50 - :mean-assertion (partial > 5000)})) + {:description "Generated Session Compilation" + :func #(com/mk-session rules) + :iterations 50 + :mean-assertion (partial > 5000)})) (let [session (com/mk-session rules) os (ByteArrayOutputStream.)] (testing "Session rulebase serialization performance" (utils/run-performance-test - {:description "Session rulebase serialization" - :func #(dura/serialize-rulebase - session - (fres/create-session-serializer (ByteArrayOutputStream.))) - :iterations 50 - :mean-assertion (partial > 1000)})) + {:description "Session rulebase serialization" + :func #(dura/serialize-rulebase + session + (fres/create-session-serializer (ByteArrayOutputStream.))) + :iterations 50 + :mean-assertion (partial > 1000)})) (testing "Session rulebase deserialization performance" (dura/serialize-rulebase - session - (fres/create-session-serializer os)) + session + (fres/create-session-serializer os)) (let [session-bytes (.toByteArray os)] (utils/run-performance-test - {:description "Session rulebase deserialization" - :func #(dura/deserialize-rulebase - (fres/create-session-serializer (ByteArrayInputStream. session-bytes))) - :iterations 50 - :mean-assertion (partial > 5000)})))))) + {:description "Session rulebase deserialization" + :func #(dura/deserialize-rulebase + (fres/create-session-serializer (ByteArrayInputStream. session-bytes))) + :iterations 50 + :mean-assertion (partial > 5000)})))))) diff --git a/src/test/common/clara/performance/test_rule_execution.cljc b/src/test/clojure/clara/performance/test_rule_execution.clj similarity index 82% rename from src/test/common/clara/performance/test_rule_execution.cljc rename to src/test/clojure/clara/performance/test_rule_execution.clj index 44707311..ed2c35de 100644 --- a/src/test/common/clara/performance/test_rule_execution.cljc +++ b/src/test/clojure/clara/performance/test_rule_execution.clj @@ -1,13 +1,8 @@ (ns clara.performance.test-rule-execution (:require [clara.rules.accumulators :as acc] [clara.rules :as r] - #?(:clj [clojure.test :refer :all] - :cljs [cljs.test :refer-macros [is deftest]]) - #?(:clj - [clara.tools.testing-utils :refer [def-rules-test run-performance-test]] - :cljs [clara.tools.testing-utils :refer [run-performance-test]])) - #?(:cljs (:require-macros [clara.tools.testing-utils :refer [def-rules-test]]))) + [clara.tools.testing-utils :refer [def-rules-test run-performance-test]])) (defrecord AFact [id]) (defrecord BFact [id]) @@ -16,7 +11,7 @@ (def counter (atom {:a-count 0 :b-count 0})) -(def number-of-facts #?(:clj 1500 :cljs 150)) +(def number-of-facts 1500) (def-rules-test test-get-in-perf {:rules [rule [[[?parent <- ParentFact] @@ -39,4 +34,4 @@ (r/insert-all facts) r/fire-rules) :iterations 5 - :mean-assertion (partial > 10000)}))) \ No newline at end of file + :mean-assertion (partial > 10000)}))) diff --git a/src/test/clojure/clara/rule_defs.clj b/src/test/clojure/clara/rule_defs.clj new file mode 100644 index 00000000..bb9f3af5 --- /dev/null +++ b/src/test/clojure/clara/rule_defs.clj @@ -0,0 +1,37 @@ +(ns clara.rule-defs + (:require [clara.rules.accumulators :as acc] + [clara.rules.testfacts :as tf] + [clara.tools.testing-utils :as tu] + [clara.rules :refer [defrule defquery insert!]]) + (:import [clara.rules.testfacts Temperature WindSpeed ColdAndWindy])) + +;; Rule definitions used for tests in clara.test-rules-require. + +(defrule test-rule + [?t <- Temperature (< temperature 20)] + => + (reset! tu/side-effect-holder ?t)) + +(defquery cold-query + [] + [Temperature (< temperature 20) (== ?t temperature)]) + +;; Accumulator for getting the lowest temperature. +(def lowest-temp (acc/min :temperature)) + +(defquery coldest-query + [] + [?t <- lowest-temp :from [Temperature]]) + +(defrule is-cold-and-windy + "Rule to determine whether it is indeed cold and windy." + + [Temperature (< temperature 20) (== ?t temperature)] + [WindSpeed (> windspeed 30) (== ?w windspeed)] + => + (insert! (tf/->ColdAndWindy ?t ?w))) + +(defquery find-cold-and-windy + [] + [?fact <- ColdAndWindy]) + diff --git a/src/test/clojure/clara/sample_ruleset.clj b/src/test/clojure/clara/sample_ruleset.clj index 1cb6b13f..ceac8728 100644 --- a/src/test/clojure/clara/sample_ruleset.clj +++ b/src/test/clojure/clara/sample_ruleset.clj @@ -11,7 +11,6 @@ ColdAndWindy LousyWeather])) - ;;; These rules are used for unit testing loading from a namespace. (defquery freezing-locations "Query the freezing locations." diff --git a/src/test/common/clara/test_accumulation.cljc b/src/test/clojure/clara/test_accumulation.clj similarity index 78% rename from src/test/common/clara/test_accumulation.cljc rename to src/test/clojure/clara/test_accumulation.clj index 196009ee..bf74cd6c 100644 --- a/src/test/common/clara/test_accumulation.cljc +++ b/src/test/clojure/clara/test_accumulation.clj @@ -1,65 +1,35 @@ -#?(:clj - (ns clara.test-accumulation - (:require [clara.tools.testing-utils :refer [def-rules-test] :as tu] - [clara.rules :refer [fire-rules - insert - insert-all - insert-all! - insert! - retract - query - accumulate]] - [clara.rules.accumulators :as acc] - [clara.rules.testfacts :refer [->Temperature ->Cold ->WindSpeed - ->ColdAndWindy map->FlexibleFields ->TemperatureHistory - ->First ->Second ->Hot ->LousyWeather]] - [clojure.test :refer [is deftest run-tests testing use-fixtures]] - [clara.rules.accumulators] - [schema.test :as st]) - (:import [clara.rules.testfacts - Temperature - Cold - WindSpeed - ColdAndWindy - FlexibleFields - TemperatureHistory - First - Second - Hot - LousyWeather])) - - :cljs - (ns clara.test-accumulation - (:require [clara.rules :refer [fire-rules - insert - insert! - insert-all - insert-all! - retract - query - accumulate]] - [clara.rules.testfacts :refer [map->FlexibleFields FlexibleFields - ->Temperature Temperature - ->Cold Cold - ->WindSpeed WindSpeed - ->ColdAndWindy ColdAndWindy - ->TemperatureHistory TemperatureHistory - ->First First - ->Second Second - ->Hot Hot - ->LousyWeather LousyWeather]] - [clara.rules.accumulators :as acc] - [clara.tools.testing-utils :as tu] - [cljs.test] - [schema.test :as st]) - (:require-macros [clara.tools.testing-utils :refer [def-rules-test]] - [cljs.test :refer [is deftest run-tests testing use-fixtures]]))) +(ns clara.test-accumulation + (:require [clara.tools.testing-utils :refer [def-rules-test] :as tu] + [clara.rules :refer [fire-rules + insert + insert-all + insert-all! + insert! + retract + query]] + [clara.rules.accumulators :as acc] + [clara.rules.testfacts :refer [->Temperature ->Cold ->WindSpeed + ->ColdAndWindy map->FlexibleFields ->TemperatureHistory + ->First ->Second ->Hot ->LousyWeather]] + [clojure.test :refer [is deftest run-tests testing use-fixtures]] + [schema.test :as st]) + (:import [clara.rules.testfacts + Temperature + Cold + WindSpeed + ColdAndWindy + FlexibleFields + TemperatureHistory + First + Second + Hot + LousyWeather])) ;; Tests focused on DSL functionality such as binding visibility in edge cases, fact field access, etc. ;; The distinction between tests here and tests in files focused on the aspects of Clara that the DSL represents ;; may not be clear and there are borderline cases. -(use-fixtures :once st/validate-schemas #?(:clj tu/opts-fixture)) +(use-fixtures :once st/validate-schemas tu/opts-fixture) (def side-effect-holder (atom nil)) @@ -94,7 +64,7 @@ (testing "Unrelated constraint on the field and then a binding with the variable first" (reset! side-effect-holder nil) - + (-> rule1-session (insert (->Temperature 10 "MCI")) fire-rules) @@ -109,22 +79,22 @@ (defn min-fact "Function to create a new accumulator for a test." [field] - (accumulate - :retract-fn identity-retract - :reduce-fn (fn [value item] - (if (or (= value nil) - (< (field item) (field value) )) - item - value)))) + (acc/accum + {:retract-fn identity-retract + :reduce-fn (fn [value item] + (if (or (= value nil) + (< (field item) (field value))) + item + value))})) (def-rules-test test-simple-accumulator - {:queries [coldest-query [[] [[?t <- (accumulate - :retract-fn identity-retract - :reduce-fn (fn [value item] - (if (or (= value nil) - (< (:temperature item) (:temperature value) )) - item - value))) + {:queries [coldest-query [[] [[?t <- (acc/accum + {:retract-fn identity-retract + :reduce-fn (fn [value item] + (if (or (= value nil) + (< (:temperature item) (:temperature value))) + item + value))}) from [Temperature]]]] coldest-query-defined [[] [[?t <- (min-fact :temperature) from [Temperature]]]]] @@ -164,16 +134,16 @@ (defn average-value "Test accumulator that returns the average of a field" [field] - (accumulate - :initial-value [0 0] - :reduce-fn (fn [[value count] item] - [(+ value (field item)) (inc count)]) - :combine-fn (fn [[value1 count1] [value2 count2]] - [(+ value1 value2) (+ count1 count2)]) - :retract-fn identity-retract - :convert-return-fn (fn [[value count]] (if (= 0 count) - nil - (/ value count))))) + (acc/accum + {:initial-value [0 0] + :reduce-fn (fn [[value count] item] + [(+ value (field item)) (inc count)]) + :combine-fn (fn [[value1 count1] [value2 count2]] + [(+ value1 value2) (+ count1 count2)]) + :retract-fn identity-retract + :convert-return-fn (fn [[value count]] (if (= 0 count) + nil + (/ value count)))})) (def-rules-test test-accumulator-with-result @@ -196,22 +166,22 @@ (def-rules-test test-accumulate-with-retract - {:queries [coldest-query [[] [[?t <- (accumulate - :initial-value [] - :reduce-fn conj - :combine-fn concat + {:queries [coldest-query [[] [[?t <- (acc/accum + {:initial-value [] + :reduce-fn conj + :combine-fn concat - ;; Retract by removing the retracted item. - ;; In general, this would need to remove - ;; only the first matching item to achieve expected semantics. - :retract-fn (fn [reduced item] - (remove #{item} reduced)) + ;; Retract by removing the retracted item. + ;; In general, this would need to remove + ;; only the first matching item to achieve expected semantics. + :retract-fn (fn [reduced item] + (remove #{item} reduced)) - ;; Sort here and return the smallest. - :convert-return-fn (fn [reduced] - (first - (sort #(< (:temperature %1) (:temperature %2)) - reduced)))) + ;; Sort here and return the smallest. + :convert-return-fn (fn [reduced] + (first + (sort #(< (:temperature %1) (:temperature %2)) + reduced)))}) :from (Temperature (< temperature 20))]]]] @@ -233,24 +203,24 @@ {:queries [coldest-query-simple-join [[] [(WindSpeed (= ?loc location)) - [?t <- (accumulate - :retract-fn identity-retract - :reduce-fn (fn [value item] - (if (or (= value nil) - (< (:temperature item) (:temperature value) )) - item - value))) + [?t <- (acc/accum + {:retract-fn identity-retract + :reduce-fn (fn [value item] + (if (or (= value nil) + (< (:temperature item) (:temperature value))) + item + value))}) :from (Temperature (= ?loc location))]]] coldest-query-complex-join [[] [(WindSpeed (= ?loc location)) - [?t <- (accumulate - :retract-fn identity-retract - :reduce-fn (fn [value item] - (if (or (= value nil) - (< (:temperature item) (:temperature value) )) - item - value))) + [?t <- (acc/accum + {:retract-fn identity-retract + :reduce-fn (fn [value item] + (if (or (= value nil) + (< (:temperature item) (:temperature value))) + item + value))}) :from (Temperature (tu/join-filter-equals ?loc location))]]]] :sessions [simple-join-session [coldest-query-simple-join] {} @@ -296,13 +266,13 @@ (def-rules-test test-bound-accumulator-var {:queries [coldest-query [[:?loc] - [[?t <- (accumulate - :retract-fn identity-retract - :reduce-fn (fn [value item] - (if (or (= value nil) - (< (:temperature item) (:temperature value) )) - item - value))) + [[?t <- (acc/accum + {:retract-fn identity-retract + :reduce-fn (fn [value item] + (if (or (= value nil) + (< (:temperature item) (:temperature value))) + item + value))}) :from [Temperature (= ?loc location)]]]]] :sessions [empty-session [coldest-query] {}]} @@ -321,17 +291,17 @@ (def-rules-test test-accumulator-rule-with-no-fact-binding - {:rules [rule [[[(accumulate :initial-value [] - :reduce-fn conj - :retract-fn identity-retract - :combine-fn into) - from [WindSpeed]]] + {:rules [rule [[[(acc/accum {:initial-value [] + :reduce-fn conj + :retract-fn identity-retract + :combine-fn into}) + from [WindSpeed]]] (reset! side-effect-holder true)]] :sessions [empty-session [rule] {}]} (reset! side-effect-holder nil) - + (-> empty-session (insert (->WindSpeed 20 "MCI") (->WindSpeed 20 "SFO")) @@ -363,8 +333,7 @@ [:?colder-temps] set)))))] - - ;; Simple insertion of facts at once. +;; Simple insertion of facts at once. (check-result (-> empty-session (insert (->Temperature 15 "MCI") (->Temperature 10 "ORD") @@ -372,8 +341,7 @@ (->Temperature 30 "SFO")) (fire-rules))) - - ;; Insert facts separately to ensure they are combined. +;; Insert facts separately to ensure they are combined. (check-result (-> empty-session (insert (->Temperature 15 "MCI") (->Temperature 5 "LGA") @@ -631,7 +599,7 @@ (retract (->Temperature 10 "MCI")) ; retracted under same bindings as inserted, but never actually inserted fire-rules (query temp-sum-no-join))] - + (is (= (frequencies [{:?s 10 :?t 10}]) (frequencies res)))) @@ -812,7 +780,6 @@ (is (= [{:?his (->TemperatureHistory [temp-10-mci])}] temp-history)))) - (def-rules-test test-retract-initial-value-filtered {:queries [get-temp-history [[] [[?his <- TemperatureHistory]]]] @@ -873,20 +840,20 @@ fire-rules (query same-wind-and-temp))))) -(def maybe-nil-min-temp (accumulate - :retract-fn identity-retract - :reduce-fn (fn [value item] - (let [t (:temperature item)] - ;; When no :temperature return `value`. - ;; Note: `value` could be nil. - (if (and t - (or (= value nil) - (< t (:temperature value)))) - item - value))))) +(def maybe-nil-min-temp (acc/accum + {:retract-fn identity-retract + :reduce-fn (fn [value item] + (let [t (:temperature item)] + ;; When no :temperature return `value`. + ;; Note: `value` could be nil. + (if (and t + (or (= value nil) + (< t (:temperature value)))) + item + value)))})) (def-rules-test test-nil-accum-reduced-has-tokens-retracted-when-new-item-inserted - + {:rules [coldest-temp-rule-no-join [[[?coldest <- maybe-nil-min-temp :from [Temperature]]] (insert! (->Cold (:temperature ?coldest)))] @@ -957,14 +924,14 @@ (insert! (->Cold (:temperature ?coldest)))] coldest-temp-rule-join [[[:max-threshold [{:keys [temperature]}] - (= ?max-temp temperature)] + (= ?max-temp temperature)] ;; Note a non-equality based unification. ;; Gets max temp under a given max threshold. - [?coldest <- maybe-nil-min-temp :from [Temperature + [?coldest <- maybe-nil-min-temp :from [Temperature ;; Gracefully handle nil. - (< (or temperature 0) - ?max-temp)]]] + (< (or temperature 0) + ?max-temp)]]] (insert! (->Cold (:temperature ?coldest)))]] @@ -993,12 +960,12 @@ "Failed expected empty query results for AccumulateWithJoinNode."))) (defn constant-accum [v] - (accumulate - :initial-value v - :reduce-fn (constantly v) - :combine-fn (constantly v) - :retract-fn (constantly v) - :convert-return-fn identity)) + (acc/accum + {:initial-value v + :reduce-fn (constantly v) + :combine-fn (constantly v) + :retract-fn (constantly v) + :convert-return-fn identity})) (def-rules-test test-constant-accum-bindings-downstream-accumulate-node @@ -1006,8 +973,8 @@ (insert! (->TemperatureHistory [?result ?temperature]))] r2 [[[Hot (= ?hot-temp temperature)] - [?result <- (constant-accum []) :from [Cold (< temperature ?hot-temp) - (= ?temperature temperature)]]] + [?result <- (constant-accum []) :from [Cold (< temperature ?hot-temp) + (= ?temperature temperature)]]] (insert! (->TemperatureHistory [?result ?temperature]))]] :queries [q1 [[] [[TemperatureHistory (= ?temps temperatures)]]]] @@ -1021,52 +988,52 @@ "AccumulateWithJoinFilterNode"]]] (is (= (-> empty-session - fire-rules - (insert (Cold. 10) (Hot. 100)) - fire-rules - (query q1)) - [{:?temps [[] 10]}]) - (str "Single Cold fact with double firing for node type " node-type)) - - (is (= (-> empty-session - (insert (Cold. 10) (Hot. 100)) - fire-rules - (query q1)) - [{:?temps [[] 10]}]) - (str "Single Cold fact with single firing for node type " node-type)) - - (is (= (-> empty-session - fire-rules - (insert (->Cold 10) (->Cold 20) (Hot. 100)) - fire-rules - (query q1) - frequencies) - {{:?temps [[] 10]} 1 - {:?temps [[] 20]} 1}) - (str "Two Cold facts with double firing for node type " node-type)) - - (is (= (-> empty-session - fire-rules - (insert (->Cold 10) (->Cold 20) (Hot. 100)) - fire-rules - (query q1) - frequencies) - {{:?temps [[] 10]} 1 - {:?temps [[] 20]} 1}) - (str "Two Cold facts with single firing for node type " node-type)) - - (is (= (-> empty-session - (insert (->Cold 10) (->Hot 100)) - (fire-rules) - (retract (->Cold 10)) - (fire-rules) - (query q1)) - []) - (str "Retracting all elements that matched an accumulator with an initial value " - \newline - "should cause all facts downstream from the accumulator to be retracted when the accumulator creates binding groups." - \newline - "Accumulator node type: " node-type)))) + fire-rules + (insert (Cold. 10) (Hot. 100)) + fire-rules + (query q1)) + [{:?temps [[] 10]}]) + (str "Single Cold fact with double firing for node type " node-type)) + + (is (= (-> empty-session + (insert (Cold. 10) (Hot. 100)) + fire-rules + (query q1)) + [{:?temps [[] 10]}]) + (str "Single Cold fact with single firing for node type " node-type)) + + (is (= (-> empty-session + fire-rules + (insert (->Cold 10) (->Cold 20) (Hot. 100)) + fire-rules + (query q1) + frequencies) + {{:?temps [[] 10]} 1 + {:?temps [[] 20]} 1}) + (str "Two Cold facts with double firing for node type " node-type)) + + (is (= (-> empty-session + fire-rules + (insert (->Cold 10) (->Cold 20) (Hot. 100)) + fire-rules + (query q1) + frequencies) + {{:?temps [[] 10]} 1 + {:?temps [[] 20]} 1}) + (str "Two Cold facts with single firing for node type " node-type)) + + (is (= (-> empty-session + (insert (->Cold 10) (->Hot 100)) + (fire-rules) + (retract (->Cold 10)) + (fire-rules) + (query q1)) + []) + (str "Retracting all elements that matched an accumulator with an initial value " + \newline + "should cause all facts downstream from the accumulator to be retracted when the accumulator creates binding groups." + \newline + "Accumulator node type: " node-type)))) (def-rules-test nil-accumulate-node-test @@ -1105,7 +1072,7 @@ (insert! (->Cold (:temperature ?coldest-temp)))] coldest-rule-2 [[[Hot (= ?max-temp temperature)] - [?coldest-temp <- (acc/min :temperature :returns-fact true) :from [ColdAndWindy (< temperature ?max-temp)]]] + [?coldest-temp <- (acc/min :temperature :returns-fact true) :from [ColdAndWindy (< temperature ?max-temp)]]] (insert! (->Cold (:temperature ?coldest-temp)))]] :queries [cold-query [[] [[Cold (= ?t temperature)]]]] @@ -1115,46 +1082,46 @@ (doseq [[empty-session node-type] - [[session-no-join "AccumulateNode"] - [session-join "AccumulateWithJoinFilterNode"]]] + [[session-no-join "AccumulateNode"] + [session-join "AccumulateWithJoinFilterNode"]]] ;; Note: in the tests below we deliberately insert or retract one fact at a time and then fire the rules. The idea ;; is to verify that even accumulator activations and retractions that do not immediately change the tokens propagated ;; downstream are registered appropriately for the purpose of truth maintenance later. This pattern ensures that we have ;; distinct activations and retractions. - (let [all-temps-session (-> empty-session - (insert (->ColdAndWindy 10 10) (->Hot 100)) - fire-rules + (let [all-temps-session (-> empty-session + (insert (->ColdAndWindy 10 10) (->Hot 100)) + fire-rules ;; Even though the minimum won't change, the addition of an additional ;; fact with the same minimum changes how many of these facts can be retracted ;; before the minimum propagated downstream changes. - (insert (->ColdAndWindy 10 10)) - fire-rules - (insert (->ColdAndWindy 20 20)) - fire-rules) + (insert (->ColdAndWindy 10 10)) + fire-rules + (insert (->ColdAndWindy 20 20)) + fire-rules) - one-min-retracted-session (-> all-temps-session + one-min-retracted-session (-> all-temps-session ;; Even though the minimum won't change after a single retraction, we now only need ;; one retraction to change the minimum rather than two. - (retract (->ColdAndWindy 10 10)) - fire-rules) + (retract (->ColdAndWindy 10 10)) + fire-rules) - all-min-retracted (-> one-min-retracted-session - (retract (->ColdAndWindy 10 10)) - fire-rules)] + all-min-retracted (-> one-min-retracted-session + (retract (->ColdAndWindy 10 10)) + fire-rules)] - (is (= (query all-temps-session cold-query) - [{:?t 10}]) - (str "With all 3 ColdAndWindy facts in the session the minimum of 10 should be chosen for node type " node-type)) + (is (= (query all-temps-session cold-query) + [{:?t 10}]) + (str "With all 3 ColdAndWindy facts in the session the minimum of 10 should be chosen for node type " node-type)) - (is (= (query one-min-retracted-session cold-query) - [{:?t 10}]) - (str "With only one of the ColdAndWindy facts of a temperature of 10 retracted the minimum is still 10 for node type " node-type)) + (is (= (query one-min-retracted-session cold-query) + [{:?t 10}]) + (str "With only one of the ColdAndWindy facts of a temperature of 10 retracted the minimum is still 10 for node type " node-type)) - (is (= (query all-min-retracted cold-query) - [{:?t 20}]) - (str "With both ColdAndWindy facts with a temperature of 10, the new minimum is 20 for node type " node-type))))) + (is (= (query all-min-retracted cold-query) + [{:?t 20}]) + (str "With both ColdAndWindy facts with a temperature of 10, the new minimum is 20 for node type " node-type))))) (def-rules-test test-no-retractions-of-nil-initial-value-accumulator-results @@ -1231,7 +1198,7 @@ (insert! (->Cold ?coldest-temp))] filter-join [[[Hot (= ?max-temp temperature)] - [?coldest-temp <- nil-unsafe-accum-init-value-accum :from [ColdAndWindy (< temperature ?max-temp)]]] + [?coldest-temp <- nil-unsafe-accum-init-value-accum :from [ColdAndWindy (< temperature ?max-temp)]]] (insert! (->Cold ?coldest-temp))]] :sessions [hash-join-session [hash-join cold-query] {} @@ -1316,16 +1283,16 @@ (def-rules-test test-accumulate-left-retract-initial-value-new-bindings-token-add-and-remove {:rules [r1 [[[?w <- WindSpeed (= ?loc location)] - [?t <- (assoc (acc/all) :convert-return-fn (constantly [])) - :from [Temperature (= ?loc location) (= ?degrees temperature)]]] + [?t <- (assoc (acc/all) :convert-return-fn (constantly [])) + :from [Temperature (= ?loc location) (= ?degrees temperature)]]] (insert! (->TemperatureHistory [?loc ?degrees]))] r2 [[[?w <- WindSpeed (= ?loc location)] - [?t <- (assoc (acc/all) :convert-return-fn (constantly [])) + [?t <- (assoc (acc/all) :convert-return-fn (constantly [])) ;; Note that only the binding that comes from a previous condition can use a filter function ;; other than equality. The = symbol is special-cased to potentially create a new binding; ;; if we used (tu/join-filter-equals ?degrees temperature) here we would have an invalid rule constraint. - :from [Temperature (tu/join-filter-equals ?loc location) (= ?degrees temperature)]]] + :from [Temperature (tu/join-filter-equals ?loc location) (= ?degrees temperature)]]] (insert! (->TemperatureHistory [?loc ?degrees]))]] :queries [q [[] [[TemperatureHistory (= ?ts temperatures)]]]] @@ -1356,11 +1323,11 @@ (def-rules-test test-accumulate-with-bindings-from-parent {:rules [r1 [[[?w <- WindSpeed (= ?loc location)] - [?ts <- (acc/all) :from [Temperature (= ?loc location)]]] + [?ts <- (acc/all) :from [Temperature (= ?loc location)]]] (insert! (->TemperatureHistory [?loc (map :temperature ?ts)]))] r2 [[[?w <- WindSpeed (= ?loc location)] - [?ts <- (acc/all) :from [Temperature (tu/join-filter-equals ?loc location)]]] + [?ts <- (acc/all) :from [Temperature (tu/join-filter-equals ?loc location)]]] (insert! (->TemperatureHistory [?loc (map :temperature ?ts)]))]] :queries [q [[] [[TemperatureHistory (= ?ts temperatures)]]]] @@ -1371,37 +1338,37 @@ (doseq [[empty-session join-type] [[s1 "simple hash join"] [s2 "filter join"]]] - (is (= (-> empty-session - (insert (->WindSpeed 10 "MCI")) - fire-rules - (query q)) - [{:?ts ["MCI" []]}]) - (str "Simple case of joining with an empty accumulator with binding from a parent" \newline - "for a " join-type)) - - (is (= (-> empty-session - (insert (->WindSpeed 10 "MCI") (->Temperature 20 "MCI")) - fire-rules - (query q)) - [{:?ts ["MCI" [20]]}]) - (str "Simple case of joining with a non-empty accumulator with a binding from a parent" \newline - "for a " join-type)) - - (is (= (-> empty-session - (insert (->WindSpeed 10 "MCI") (->Temperature 30 "MCI") (->Temperature 20 "LAX")) - fire-rules - (query q)) - [{:?ts ["MCI" [30]]}]) - (str "One value can join with parent node, but the other value has no matching parent " \newline - "for a " join-type)) - - (is (= (-> empty-session - (insert (->WindSpeed 10 "MCI") (->Temperature 20 "LAX")) - fire-rules - (query q)) - [{:?ts ["MCI" []]}]) - (str "Creation of a non-equal binding from a parent node " \newline - "should not allow an accumulator to fire for another binding value for a " join-type)))) + (is (= (-> empty-session + (insert (->WindSpeed 10 "MCI")) + fire-rules + (query q)) + [{:?ts ["MCI" []]}]) + (str "Simple case of joining with an empty accumulator with binding from a parent" \newline + "for a " join-type)) + + (is (= (-> empty-session + (insert (->WindSpeed 10 "MCI") (->Temperature 20 "MCI")) + fire-rules + (query q)) + [{:?ts ["MCI" [20]]}]) + (str "Simple case of joining with a non-empty accumulator with a binding from a parent" \newline + "for a " join-type)) + + (is (= (-> empty-session + (insert (->WindSpeed 10 "MCI") (->Temperature 30 "MCI") (->Temperature 20 "LAX")) + fire-rules + (query q)) + [{:?ts ["MCI" [30]]}]) + (str "One value can join with parent node, but the other value has no matching parent " \newline + "for a " join-type)) + + (is (= (-> empty-session + (insert (->WindSpeed 10 "MCI") (->Temperature 20 "LAX")) + fire-rules + (query q)) + [{:?ts ["MCI" []]}]) + (str "Creation of a non-equal binding from a parent node " \newline + "should not allow an accumulator to fire for another binding value for a " join-type)))) (def-rules-test test-accumulate-with-explicit-nil-binding-value @@ -1409,11 +1376,11 @@ (insert! (->Temperature [?t []] "MCI"))] binding-from-parent [[[Cold (= ?t temperature)] - [?hot-facts <- (acc/all) :from [Hot (= ?t temperature)]]] + [?hot-facts <- (acc/all) :from [Hot (= ?t temperature)]]] (insert! (->Temperature [?t []] "MCI"))] binding-from-parent-non-equals [[[Cold (= ?t temperature)] - [?hot-facts <- (acc/all) :from [Hot (tu/join-filter-equals ?t temperature)]]] + [?hot-facts <- (acc/all) :from [Hot (tu/join-filter-equals ?t temperature)]]] (insert! (->Temperature [?t []] "MCI"))]] :queries [q [[] [[Temperature (= ?t temperature)]]]] @@ -1423,10 +1390,10 @@ s3 [binding-from-parent-non-equals q] {}]} (is (= [{:?t [nil []]}] - (-> s1 - (insert (->Hot nil)) - fire-rules - (query q))) + (-> s1 + (insert (->Hot nil)) + fire-rules + (query q))) "An explicit value of nil in a field used to create a binding group should allow the binding to be created.") (doseq [[empty-session constraint-type] [[s2 "simple hash join"] @@ -1606,14 +1573,14 @@ {:queries [q [[] [[TemperatureHistory (= ?ws temperatures)]]]] :rules [r1 [[[Cold (= ?t temperature)] - [?ws <- (acc/all) :from [ColdAndWindy - (and (tu/join-filter-equals ?t temperature) - (even? windspeed))]]] + [?ws <- (acc/all) :from [ColdAndWindy + (and (tu/join-filter-equals ?t temperature) + (even? windspeed))]]] (insert! (->TemperatureHistory (map :windspeed ?ws)))] r2 [[[Cold (= ?t temperature)] - [?ws <- (acc/all) :from [ColdAndWindy (= ?t temperature) - (even? windspeed)]]] + [?ws <- (acc/all) :from [ColdAndWindy (= ?t temperature) + (even? windspeed)]]] (insert! (->TemperatureHistory (map :windspeed ?ws)))]] :sessions [s1 [r1 q] {} @@ -1622,58 +1589,58 @@ (doseq [[empty-session join-type] [[s1 "filter join"] [s2 "simple hash join"]] - :let [non-matching-first (-> empty-session - (insert (->ColdAndWindy 10 23)) - (insert (->ColdAndWindy 10 20)) - (insert (->ColdAndWindy 10 22)) - (insert (->Cold 10)) - fire-rules) + :let [non-matching-first (-> empty-session + (insert (->ColdAndWindy 10 23)) + (insert (->ColdAndWindy 10 20)) + (insert (->ColdAndWindy 10 22)) + (insert (->Cold 10)) + fire-rules) - non-matching-middle (-> empty-session - (insert (->ColdAndWindy 10 20)) - (insert (->ColdAndWindy 10 23)) - (insert (->ColdAndWindy 10 22)) - (insert (->Cold 10)) - fire-rules) - - non-matching-last (-> empty-session + non-matching-middle (-> empty-session (insert (->ColdAndWindy 10 20)) - (insert (->ColdAndWindy 10 22)) (insert (->ColdAndWindy 10 23)) + (insert (->ColdAndWindy 10 22)) (insert (->Cold 10)) fire-rules) - [first-removed middle-removed last-removed] (for [init-session [non-matching-first - non-matching-middle - non-matching-last]] - (-> init-session - (retract (->ColdAndWindy 10 23)) + non-matching-last (-> empty-session + (insert (->ColdAndWindy 10 20)) + (insert (->ColdAndWindy 10 22)) + (insert (->ColdAndWindy 10 23)) + (insert (->Cold 10)) + fire-rules) + + [first-removed middle-removed last-removed] (for [init-session [non-matching-first + non-matching-middle + non-matching-last]] + (-> init-session + (retract (->ColdAndWindy 10 23)) ;; Perform an additional operation to reveal any discrepancy between the element ordering ;; in the candidates and the resulting ordering in downstream tokens. - (insert (->ColdAndWindy 10 24)) - fire-rules)) + (insert (->ColdAndWindy 10 24)) + fire-rules)) - without-rhs-ordering (fn [query-results] - (map (fn [result] - (update result :?ws set)) - query-results))]] + without-rhs-ordering (fn [query-results] + (map (fn [result] + (update result :?ws set)) + query-results))]] - (is (= [{:?ws #{20 22}}] + (is (= [{:?ws #{20 22}}] ;; Put elements in a set to be independent of the ordering of acc/all in the assertions. ;; All we care about is that the cardinality of the query results is correct, which may ;; not be the case if the ordering is inconsistent between operations. User code, however, needs ;; to be OK with getting any ordering in the RHS, so we just test that contract here. - (without-rhs-ordering (query non-matching-first q)) - (without-rhs-ordering (query non-matching-middle q)) - (without-rhs-ordering (query non-matching-last q))) - (str "Sanity test of our rule that does not exercise right-retract, the main purpose of this test, for a " join-type)) - - (doseq [[final-session message] [[first-removed "first right activation"] - [middle-removed "middle right activation"] - [last-removed "last right activation"]]] - (is (= [{:?ws #{20 22 24}}] - (without-rhs-ordering (query final-session q))) - (str "Retracting non-matching " message "for a " join-type))))) + (without-rhs-ordering (query non-matching-first q)) + (without-rhs-ordering (query non-matching-middle q)) + (without-rhs-ordering (query non-matching-last q))) + (str "Sanity test of our rule that does not exercise right-retract, the main purpose of this test, for a " join-type)) + + (doseq [[final-session message] [[first-removed "first right activation"] + [middle-removed "middle right activation"] + [last-removed "last right activation"]]] + (is (= [{:?ws #{20 22 24}}] + (without-rhs-ordering (query final-session q))) + (str "Retracting non-matching " message "for a " join-type))))) (def min-accum-convert-return-fn-nil-to-zero (acc/min :temperature)) @@ -1682,32 +1649,32 @@ {:queries [lousy-weather-query [[] [[LousyWeather]]]] :rules [min-non-cold [[[?min-cold <- (acc/min :temperature) :from [Cold]] - [?min-temp <- (acc/min :temperature) :from [Temperature (< temperature ?min-cold)]]] + [?min-temp <- (acc/min :temperature) :from [Temperature (< temperature ?min-cold)]]] (insert! (->LousyWeather))]] :sessions [empty-session [lousy-weather-query min-non-cold] {}]} - (is (empty? (-> empty-session - (insert (->Temperature 20 "MCI")) - (insert (->Cold 10)) - fire-rules - (query lousy-weather-query))) - "Insert non-matching element first then the token.") + (is (empty? (-> empty-session + (insert (->Temperature 20 "MCI")) + (insert (->Cold 10)) + fire-rules + (query lousy-weather-query))) + "Insert non-matching element first then the token.") - (is (empty? (-> empty-session - (insert (->Cold 10)) - (insert (->Temperature 20 "MCI")) - fire-rules - (query lousy-weather-query))) - "Insert token first then non-matching element.") + (is (empty? (-> empty-session + (insert (->Cold 10)) + (insert (->Temperature 20 "MCI")) + fire-rules + (query lousy-weather-query))) + "Insert token first then non-matching element.") - (is (empty? (-> empty-session - (insert (->Cold 10) (->Temperature 20 "MCI")) - fire-rules - (retract (->Temperature 20 "MCI")) - fire-rules - (query lousy-weather-query))) - "Insert facts matching both conditions first and then remove a Temperature fact, thus causing the accumulator on Temperature to + (is (empty? (-> empty-session + (insert (->Cold 10) (->Temperature 20 "MCI")) + fire-rules + (retract (->Temperature 20 "MCI")) + fire-rules + (query lousy-weather-query))) + "Insert facts matching both conditions first and then remove a Temperature fact, thus causing the accumulator on Temperature to right-retract back to its initial value. Since the initial value is nil the activation of the rule should be removed.")) (def-rules-test test-initial-value-used-when-non-nil-and-new-binding-group-created @@ -1718,7 +1685,7 @@ {:queries [q [[] [[TemperatureHistory (= ?ts temperatures)]]]] :rules [hash-join-rule [[[WindSpeed (= ?loc location)] - [?temp-count <- (acc/count) :from [Temperature (= ?loc location) (= ?temp temperature)]]] + [?temp-count <- (acc/count) :from [Temperature (= ?loc location) (= ?temp temperature)]]] (insert! (->TemperatureHistory [?loc ?temp ?temp-count]))] filter-join-rule [[[WindSpeed (= ?loc location)] @@ -1733,20 +1700,20 @@ [empty-session-filter-join "join filter"]]] - (is (= (-> empty-session - (insert (->WindSpeed 10 "MCI")) - fire-rules - (insert (->Temperature 20 "MCI")) - fire-rules - (query q)) - [{:?ts ["MCI" 20 1]}]) - (str "Inserting a WindSpeed and then later a matching Temperature for join type " join-type)))) + (is (= (-> empty-session + (insert (->WindSpeed 10 "MCI")) + fire-rules + (insert (->Temperature 20 "MCI")) + fire-rules + (query q)) + [{:?ts ["MCI" 20 1]}]) + (str "Inserting a WindSpeed and then later a matching Temperature for join type " join-type)))) (def-rules-test test-retract-of-fact-matching-accumulator-causes-downstream-retraction {:rules [create-cold [[[?cs <- (acc/all) :from [ColdAndWindy]]] - (doseq [c ?cs] - (insert! (->Cold (:temperature c))))] + (doseq [c ?cs] + (insert! (->Cold (:temperature c))))] temp-from-cold [[[Cold (= ?t temperature)]] (insert! (->Temperature ?t "MCI"))]] diff --git a/src/test/common/clara/test_accumulators.cljc b/src/test/clojure/clara/test_accumulators.clj similarity index 88% rename from src/test/common/clara/test_accumulators.cljc rename to src/test/clojure/clara/test_accumulators.clj index 6459e18d..e6feac7d 100644 --- a/src/test/common/clara/test_accumulators.cljc +++ b/src/test/clojure/clara/test_accumulators.clj @@ -1,46 +1,26 @@ -#?(:clj - (ns clara.test-accumulators - (:require [clara.tools.testing-utils :refer [def-rules-test] :as tu] - [clara.rules :refer [fire-rules - insert - insert-all - insert! - retract - query]] - - [clara.rules.testfacts :refer [->Temperature ->Cold ->WindSpeed - ->TemperatureHistory]] - [clojure.test :refer [is deftest run-tests testing use-fixtures]] - [clara.rules.accumulators :as acc] - [schema.test :as st]) - (:import [clara.rules.testfacts - Temperature - TemperatureHistory - Cold - WindSpeed])) - - :cljs - (ns clara.test-accumulators - (:require [clara.rules :refer [fire-rules - insert - insert! - insert-all - retract - query]] - [clara.rules.accumulators :as acc] - [clara.rules.testfacts :refer [->Temperature Temperature - ->TemperatureHistory TemperatureHistory - ->Cold Cold - ->WindSpeed WindSpeed]] - [cljs.test :as test] - [schema.test :as st]) - (:require-macros [clara.tools.testing-utils :refer [def-rules-test]] - [cljs.test :refer [is deftest run-tests testing use-fixtures]]))) - -(use-fixtures :once st/validate-schemas #?(:clj tu/opts-fixture)) - +(ns clara.test-accumulators + (:require [clara.tools.testing-utils :refer [def-rules-test] :as tu] + [clara.rules :refer [fire-rules + insert + insert-all + insert! + retract + query]] + + [clara.rules.testfacts :refer [->Temperature ->Cold ->WindSpeed + ->TemperatureHistory]] + [clojure.test :refer [is deftest run-tests testing use-fixtures]] + [clara.rules.accumulators :as acc] + [schema.test :as st]) + (:import [clara.rules.testfacts + Temperature + TemperatureHistory + Cold + WindSpeed])) + +(use-fixtures :once st/validate-schemas tu/opts-fixture) + (def-rules-test test-max - {:queries [hottest [[] [[?t <- (acc/max :temperature) from [Temperature]]]]] @@ -128,7 +108,6 @@ (is (empty (query empty-session hottest))) (is (= [{:?t 80}] (query session hottest))) - (is (= #{{:?t (->Temperature 80 "MCI")}} (set (query session hottest-fact)))) @@ -137,22 +116,28 @@ (is (= (list {:?t 20}) (query max-retracted average-temp))))) (def-rules-test test-sum - {:queries [sum-query [[] [[?t <- (acc/sum :temperature) from [Temperature]]]]] + {:queries [sum-query [[] [[?t <- (acc/sum :temperature) from [Temperature]]]] + + sum-query-with-default [[] [[?t <- (acc/sum :temperature :default-value 10) from [Temperature]]]]] + + :sessions [empty-session [sum-query sum-query-with-default] {}]} - :sessions [empty-session [sum-query] {}]} - (let [session (-> empty-session (insert (->Temperature 30 "MCI")) (insert (->Temperature 10 "MCI")) + (insert (->Temperature nil "MCI")) (insert (->Temperature 80 "MCI")) fire-rules) retracted (-> session (retract (->Temperature 30 "MCI")) + (retract (->Temperature nil "MCI")) fire-rules)] (is (= [{:?t 120}] (query session sum-query))) - (is (= [{:?t 90}] (query retracted sum-query))))) + (is (= [{:?t 130}] (query session sum-query-with-default))) + (is (= [{:?t 90}] (query retracted sum-query))) + (is (= [{:?t 90}] (query retracted sum-query-with-default))))) (def-rules-test test-count {:queries [count-query [[] [[?c <- (acc/count) from [Temperature]]]]] @@ -169,7 +154,7 @@ (retract (->Temperature 30 "MCI")) fire-rules)] - (is (= [{:?c 0}] (query empty-session count-query))) + (is (= [{:?c 0}] (query empty-session count-query))) (is (= [{:?c 3}] (query session count-query))) (is (= [{:?c 2}] (query retracted count-query))))) @@ -189,17 +174,17 @@ (retract (->Temperature 90 "MCI")) fire-rules)] - (is (= #{{:?t #{ (->Temperature 80 "MCI") + (is (= #{{:?t #{(->Temperature 80 "MCI") (->Temperature 90 "MCI")}}} (set (query session distinct-query)))) - (is (= #{{:?t #{ (->Temperature 80 "MCI")}}} + (is (= #{{:?t #{(->Temperature 80 "MCI")}}} (set (query retracted distinct-query)))) - (is (= #{{:?t #{ 80 90}}} + (is (= #{{:?t #{80 90}}} (set (query session distinct-field-query)))) - (is (= #{{:?t #{ 80}}} + (is (= #{{:?t #{80}}} (set (query retracted distinct-field-query)))) ;; Tests for https://github.com/cerner/clara-rules/issues/325 without the field argument. @@ -414,12 +399,12 @@ (def reduced-max-accum (acc/reduce-to-accum - (fn [previous value] - (if previous - (if (> (:temperature value) (:temperature previous)) - value - previous) - value)))) + (fn [previous value] + (if previous + (if (> (:temperature value) (:temperature previous)) + value + previous) + value)))) (def-rules-test test-reduce-to-accum-max @@ -550,4 +535,4 @@ (testing "Custom initial value structure is maintained" (is (and (= (count (query session wind-query)) 1) (= [(->WindSpeed 75 "KCI")] wind-facts) - (seq? wind-facts)))))) \ No newline at end of file + (seq? wind-facts)))))) diff --git a/src/test/common/clara/test_bindings.cljc b/src/test/clojure/clara/test_bindings.clj similarity index 86% rename from src/test/common/clara/test_bindings.cljc rename to src/test/clojure/clara/test_bindings.clj index c1f6766c..a868dd49 100644 --- a/src/test/common/clara/test_bindings.cljc +++ b/src/test/clojure/clara/test_bindings.clj @@ -1,47 +1,27 @@ -#?(:clj - (ns clara.test-bindings - "Tests focused on the creation of binding variables and their use - in joins between rule and query condition. Binding variables - begin with ?." - (:require [clara.tools.testing-utils :refer [def-rules-test] :as tu] - [clara.rules :refer [fire-rules - insert - insert-all - insert! - retract - query]] - - [clara.rules.testfacts :refer [->Temperature ->Cold ->WindSpeed - ->ColdAndWindy]] - [clojure.test :refer [is deftest run-tests testing use-fixtures]] - [clara.rules.accumulators :as acc] - [schema.test :as st]) - (:import [clara.rules.testfacts - Temperature - Cold - WindSpeed - ColdAndWindy])) - - :cljs - (ns clara.test-bindings - (:require [clara.rules :refer [fire-rules - insert - insert! - insert-all - retract - query]] - [clara.rules.testfacts :refer [->Temperature Temperature - ->Cold Cold - ->WindSpeed WindSpeed - ->ColdAndWindy ColdAndWindy]] - [clara.rules.accumulators :as acc] - [cljs.test] - [schema.test :as st] - [clara.tools.testing-utils :as tu]) - (:require-macros [clara.tools.testing-utils :refer [def-rules-test]] - [cljs.test :refer [is deftest run-tests testing use-fixtures]]))) - -(use-fixtures :once st/validate-schemas #?(:clj tu/opts-fixture)) +(ns clara.test-bindings + "Tests focused on the creation of binding variables and their use + in joins between rule and query condition. Binding variables + begin with ?." + (:require [clara.tools.testing-utils :refer [def-rules-test] :as tu] + [clara.rules :refer [fire-rules + insert + insert-all + insert! + retract + query]] + + [clara.rules.testfacts :refer [->Temperature ->Cold ->WindSpeed + ->ColdAndWindy]] + [clojure.test :refer [is deftest run-tests testing use-fixtures]] + [clara.rules.accumulators :as acc] + [schema.test :as st]) + (:import [clara.rules.testfacts + Temperature + Cold + WindSpeed + ColdAndWindy])) + +(use-fixtures :once st/validate-schemas tu/opts-fixture) (use-fixtures :each tu/side-effect-holder-fixture) (def side-effect-atom (atom nil)) @@ -190,7 +170,7 @@ {:queries [temps-with-addition [[] [[Temperature (= ?t1 temperature) - (= "MCI" location )] + (= "MCI" location)] [Temperature (= ?t2 temperature) (= ?foo (+ 20 ?t1)) (= "SFO" location)] @@ -200,7 +180,7 @@ temps-with-negation [[] [[Temperature (= ?t1 temperature) - (= "MCI" location )] + (= "MCI" location)] [Temperature (= ?t2 temperature) (= ?foo (+ 20 ?t1)) (= "SFO" location)] @@ -220,8 +200,7 @@ (fire-rules) (query temps-with-addition)))) - - ;; Test if not all conditions are satisfied. +;; Test if not all conditions are satisfied. (is (empty? (-> session (insert (->Temperature 10 "MCI") (->Temperature 21 "SFO") @@ -344,7 +323,6 @@ (is (= [{:?x nil}] (query session test-query))))) - ;; https://github.com/cerner/clara-rules/issues/357 (def-rules-test test-accumulator-before-equality-test-in-test-node diff --git a/src/test/clojure/clara/test_clear_ns_vars.clj b/src/test/clojure/clara/test_clear_ns_vars.clj new file mode 100644 index 00000000..0847c4f7 --- /dev/null +++ b/src/test/clojure/clara/test_clear_ns_vars.clj @@ -0,0 +1,69 @@ +;;; Tests that clear-ns-vars! correction clears all vars marked as productions from the namespace. +(ns clara.test-clear-ns-vars + (:require + [clara.rules :refer [clear-ns-vars! defquery defrule defsession + fire-rules insert insert! query]] + [clara.tools.testing-utils :as tu] + [clojure.test :refer [deftest is testing use-fixtures]]) + (:import + [java.lang IllegalArgumentException])) + +(use-fixtures :each tu/side-effect-holder-fixture) + +(defrule rule-to-be-cleared + [:a] + => + (reset! tu/side-effect-holder :before-clearing) + (insert! :before-clearing)) + +(defquery query-to-be-cleared [] [?f <- :before-clearing]) + +(def ^:production-seq ns-production-seq-to-be-cleared + [{:doc "Before clearing" + :name "clara.test-clear-ns-vars/production-seq-to-be-cleared" + :lhs '[{:type :a + :constraints []}] + :rhs '(clara.rules/insert! :before-clearing-seq)}]) + +(defsession uncleared-session 'clara.test-clear-ns-vars :fact-type-fn identity) + +(clear-ns-vars!) + +(defrule rule-after-clearing + [:a] + => + (insert! :after-clearing)) + +(defquery query-before-clearing [] [?f <- :before-clearing]) +(defquery query-after-clearing [] [?f <- :after-clearing]) +(defquery query-before-clearing-seq [] [?f <- :before-clearing-seq]) +(defquery query-after-clearing-seq [] [?f <- :after-clearing-seq]) + +(def ^:production-seq production-seq-after-clearing + [{:doc "After clearing" + :name "clara.test-clear-ns-vars/production-seq-after-clearing" + :lhs '[{:type :a + :constraints []}] + :rhs '(clara.rules/insert! :after-clearing-seq)}]) + +(defsession cleared-session 'clara.test-clear-ns-vars :fact-type-fn identity) + +;;; Then tests validating what productions the respective sessions have. +(deftest cleared? + (let [uncleared (-> uncleared-session (insert :a) (fire-rules))] + (is (= :before-clearing @tu/side-effect-holder)) + (reset! tu/side-effect-holder nil)) + (let [cleared (-> cleared-session (insert :a) (fire-rules))] + (testing "cleared-session should not contain any productions before (clear-ns-vars!)" + (is (= nil @tu/side-effect-holder)) + (is (empty? (query cleared query-before-clearing))) + (is (not-empty (query cleared query-after-clearing)))) + (is (empty? (query cleared query-before-clearing-seq))) + (is (not-empty (query cleared query-after-clearing-seq))))) + +(deftest query-cleared? + (let [uncleared (-> uncleared-session (insert :a) (fire-rules)) + cleared (-> cleared-session (insert :a) (fire-rules))] + (is (not-empty (query uncleared "clara.test-clear-ns-vars/query-to-be-cleared"))) + (is (thrown-with-msg? IllegalArgumentException #"clara.test-clear-ns-vars/query-to-be-cleared" + (query cleared "clara.test-clear-ns-vars/query-to-be-cleared"))))) diff --git a/src/test/common/clara/test_common.cljc b/src/test/clojure/clara/test_common.clj similarity index 81% rename from src/test/common/clara/test_common.cljc rename to src/test/clojure/clara/test_common.clj index 386d9906..83ed03ad 100644 --- a/src/test/common/clara/test_common.cljc +++ b/src/test/clojure/clara/test_common.clj @@ -1,16 +1,12 @@ (ns clara.test-common "Common tests for Clara in Clojure and ClojureScript." - (:require #?(:clj [clojure.test :refer :all] - :cljs [cljs.test :refer-macros [is deftest testing]]) - - #?(:clj [clara.rules :refer [defrule defsession defquery - insert fire-rules query]] - :cljs [clara.rules :refer [insert fire-rules query] - :refer-macros [defrule defsession defquery]]) - - [clara.rules.accumulators :as acc] - - [clara.rules.platform :as platform])) + (:require + [clara.rules :refer [defquery defrule defsession fire-rules insert query]] + [clara.rules.accumulators :as acc] + [clara.rules.platform :as platform] + [clojure.test :refer :all]) + (:import + [java.lang IllegalArgumentException])) (defn- has-fact? [token fact] (some #{fact} (map first (:matches token)))) @@ -59,7 +55,6 @@ (is (= #{{:?t 15} {:?t 10}} (set (query session cold-query)))))) - (defquery temps-below-threshold [] [:threshold [{value :value}] (= ?threshold value)] @@ -70,12 +65,12 @@ (deftest test-accum-with-filter (is (= [{:?threshold 0, :?low-temps []}] - (-> accum-with-filter-session - (insert {:type :temperature :value 20}) - (insert {:type :threshold :value 0}) - (insert {:type :temperature :value 10}) - fire-rules - (query temps-below-threshold)))) + (-> accum-with-filter-session + (insert {:type :temperature :value 20}) + (insert {:type :threshold :value 0}) + (insert {:type :temperature :value 10}) + fire-rules + (query temps-below-threshold)))) (let [results (-> accum-with-filter-session (insert {:type :temperature :value 20}) @@ -85,7 +80,7 @@ fire-rules (query temps-below-threshold)) - [{threshold :?threshold low-temps :?low-temps }] results] + [{threshold :?threshold low-temps :?low-temps}] results] (is (= 1 (count results))) @@ -120,11 +115,9 @@ (try (platform/query-param "?value") (is false "Running the rules in this test should cause an exception.") - (catch #?(:clj java.lang.IllegalArgumentException - :cljs js/Error) e + (catch IllegalArgumentException e (is (= "Query bindings must be specified as a keyword or symbol: ?value" - #?(:clj (.getMessage e) - :cljs (.-message e)))))))) + (.getMessage e))))))) (defsession negation-with-filter-session [none-below-threshold] :fact-type-fn :type) diff --git a/src/test/clojure/clara/test_compiler.clj b/src/test/clojure/clara/test_compiler.clj index 0541a37d..17daea7d 100644 --- a/src/test/clojure/clara/test_compiler.clj +++ b/src/test/clojure/clara/test_compiler.clj @@ -52,9 +52,7 @@ RootJoinNode []))] (doseq [node (-> base-session eng/components :rulebase :id-to-node vals) node-fn (get-node-fns node)] - (is (seq (re-find (re-pattern (str (get eng/node-type->abbreviated-type (.getSimpleName (class node))) - "-" - (:id node))) + (is (seq (re-find (re-pattern (str (get eng/node-type->abbreviated-type (.getSimpleName (class node))))) (-> node-fn str m/demunge (str/split #"/") last))) (str "For node: " node " and node-fn: " node-fn))))) diff --git a/src/test/clojure/clara/test_coverage.clj b/src/test/clojure/clara/test_coverage.clj new file mode 100644 index 00000000..2a079a1d --- /dev/null +++ b/src/test/clojure/clara/test_coverage.clj @@ -0,0 +1,14 @@ +(ns ^:coverage clara.test-coverage + (:require [clojure.test :refer [deftest testing is]] + [clara.rules :refer [mk-session insert fire-rules query]] + [clara.coverage-ruleset])) + +(deftest test-coverage + (testing "run the rules" + (let [result (-> (mk-session 'clara.coverage-ruleset :fact-type-fn :type) + (insert {:type :weather + :temperature 75}) + (fire-rules) + (query clara.coverage-ruleset/climate-query))] + (is (= result [{:?result {:type :climate + :label "Warm"}}]))))) diff --git a/src/test/common/clara/test_dsl.cljc b/src/test/clojure/clara/test_dsl.clj similarity index 52% rename from src/test/common/clara/test_dsl.cljc rename to src/test/clojure/clara/test_dsl.clj index 3d5a3c74..5145ed94 100644 --- a/src/test/common/clara/test_dsl.cljc +++ b/src/test/clojure/clara/test_dsl.clj @@ -1,61 +1,30 @@ -#?(:clj - (ns clara.test-dsl - (:require [clara.tools.testing-utils :refer [def-rules-test] :as tu] - [clara.rules :refer [fire-rules - insert - insert-all - insert-all! - insert! - retract - query]] - [clara.rules.accumulators :as acc] - [clara.rules.testfacts :refer [->Temperature ->Cold ->WindSpeed - ->ColdAndWindy map->FlexibleFields - ->First ->Second ->Third ->Fourth]] - [clojure.test :refer [is deftest run-tests testing use-fixtures]] - [clara.rules.accumulators] - [schema.test :as st]) - (:import [clara.rules.testfacts - Temperature - Cold - WindSpeed - ColdAndWindy - FlexibleFields - First - Second - Third - Fourth])) - - :cljs - (ns clara.test-dsl - (:require [clara.rules :refer [fire-rules - insert - insert! - insert-all - insert-all! - retract - query]] - [clara.rules.testfacts :refer [map->FlexibleFields FlexibleFields - ->Temperature Temperature - ->Cold Cold - ->WindSpeed WindSpeed - ->ColdAndWindy ColdAndWindy - ->First First - ->Second Second - ->Third Third - ->Fourth Fourth]] - [clara.rules.accumulators :as acc] - [clara.tools.testing-utils :as tu] - [cljs.test] - [schema.test :as st]) - (:require-macros [clara.tools.testing-utils :refer [def-rules-test]] - [cljs.test :refer [is deftest run-tests testing use-fixtures]]))) +(ns clara.test-dsl + (:require + [clara.rules :refer :all] + [clara.rules.testfacts :refer [->Cold ->First ->Fourth ->Second + ->Temperature ->Third ->WindSpeed map->FlexibleFields]] + [clara.tools.testing-utils :refer [def-rules-test] :as tu] + [clojure.test :refer [is testing use-fixtures]] + [schema.test :as st]) + (:import + [java.util TimeZone]) + (:import [clara.rules.testfacts + Temperature + WindSpeed + Cold + ColdAndWindy + LousyWeather + First + Second + Third + Fourth + FlexibleFields])) ;; Tests focused on DSL functionality such as binding visibility in edge cases, fact field access, etc. ;; The distinction between tests here and tests in files focused on the aspects of Clara that the DSL represents ;; may not be clear and there are borderline cases. -(use-fixtures :once st/validate-schemas #?(:clj tu/opts-fixture)) +(use-fixtures :once st/validate-schemas tu/opts-fixture) (def side-effect-holder (atom nil)) @@ -80,7 +49,7 @@ (testing "Unrelated constraint on the field and then a binding with the variable first" (reset! side-effect-holder nil) - + (-> rule1-session (insert (->Temperature 10 "MCI")) fire-rules) @@ -89,7 +58,7 @@ (testing "A binding with the variable first and then an unrelated constraint on the field" (reset! side-effect-holder nil) - + (-> rule2-session (insert (->Temperature 10 "MCI")) fire-rules) @@ -98,7 +67,7 @@ (testing "Unrelated constraint on the field and then a binding with the variable second" (reset! side-effect-holder nil) - + (-> rule3-session (insert (->Temperature 10 "MCI")) fire-rules) @@ -107,7 +76,7 @@ (testing "A binding with the variable second and then an unrelated constraint on the field" (reset! side-effect-holder nil) - + (-> rule4-session (insert (->Temperature 10 "MCI")) fire-rules) @@ -133,24 +102,23 @@ :?u 10 :?v 10}))) -#?(:clj - (def-rules-test test-bean-test - {:queries [tz-offset-query [[:?offset] - [[java.util.TimeZone (= ?offset rawOffset) - (= ?id ID)]]]] +(def-rules-test test-bean-test + {:queries [tz-offset-query [[:?offset] + [[java.util.TimeZone (= ?offset rawOffset) + (= ?id ID)]]]] - :sessions [empty-session [tz-offset-query] {}]} + :sessions [empty-session [tz-offset-query] {}]} - (let [session (-> empty-session - (insert (java.util.TimeZone/getTimeZone "America/Chicago") - (java.util.TimeZone/getTimeZone "UTC")) - fire-rules)] + (let [session (-> empty-session + (insert (TimeZone/getTimeZone "America/Chicago") + (TimeZone/getTimeZone "UTC")) + fire-rules)] - (is (= #{{:?id "America/Chicago" :?offset -21600000}} - (set (query session tz-offset-query :?offset -21600000)))) + (is (= #{{:?id "America/Chicago" :?offset -21600000}} + (set (query session tz-offset-query :?offset -21600000)))) - (is (= #{{:?id "UTC" :?offset 0}} - (set (query session tz-offset-query :?offset 0))))))) + (is (= #{{:?id "UTC" :?offset 0}} + (set (query session tz-offset-query :?offset 0)))))) (def-rules-test test-destructured-args {:queries [cold-query [[] @@ -211,34 +179,31 @@ (is (= {{:?f 15} 1} (frequencies (query session q)))))) -;; FIXME: This doesn't pass in ClojureScript and it should. -#?(:clj - (def-rules-test test-variable-visibility +(def-rules-test test-variable-visibility + {:rules [temps-for-locations [[[:location (= ?loc (:loc this))] - {:rules [temps-for-locations [[[:location (= ?loc (:loc this))] + [Temperature + (= ?temp temperature) + ;; TODO: This comment was copied from clara.test-rules, is it still accurate? + ;; + ;; This can only have one binding right + ;; now due to work that needs to be done + ;; still in clara.rules.compiler/extract-from-constraint + ;; around support multiple bindings in a condition. + (contains? #{?loc} location)]] + (insert! (->Cold ?temp))]] - [Temperature - (= ?temp temperature) - ;; TODO: This comment was copied from clara.test-rules, is it still accurate? - ;; - ;; This can only have one binding right - ;; now due to work that needs to be done - ;; still in clara.rules.compiler/extract-from-constraint - ;; around support multiple bindings in a condition. - (contains? #{?loc} location)]] - (insert! (->Cold ?temp))]] + :queries [find-cold [[] [[?c <- Cold]]]] - :queries [find-cold [[] [[?c <- Cold]]]] + :sessions [empty-session [temps-for-locations find-cold] {}]} - :sessions [empty-session [temps-for-locations find-cold] {}]} - - (let [session (-> empty-session - (insert ^{:type :location} {:loc "MCI"}) - (insert (->Temperature 10 "MCI")) - fire-rules)] + (let [session (-> empty-session + (insert ^{:type :location} {:loc "MCI"}) + (insert (->Temperature 10 "MCI")) + fire-rules)] - (is (= {{:?c (->Cold 10)} 1} - (frequencies (query session find-cold))))))) + (is (= {{:?c (->Cold 10)} 1} + (frequencies (query session find-cold)))))) (def-rules-test test-nested-binding @@ -272,101 +237,96 @@ (fire-rules) (query same-wind-and-temp))))) -;; FIXME: Make this pass in ClojureScript -#?(:clj - ;; Test for: https://github.com/cerner/clara-rules/issues/97 - (def-rules-test test-nested-binding-with-disjunction +;; Test for: https://github.com/cerner/clara-rules/issues/97 +(def-rules-test test-nested-binding-with-disjunction - {:rules [any-cold [[[Temperature (= ?t temperature)] - [:or - [Cold (< temperature ?t)] - [Cold (< temperature 5)]]] + {:rules [any-cold [[[Temperature (= ?t temperature)] + [:or + [Cold (< temperature ?t)] + [Cold (< temperature 5)]]] - (insert! ^{:type :found-cold} {:found true})]] + (insert! ^{:type :found-cold} {:found true})]] - :queries [found-cold [[] [[?f <- :found-cold]]]] + :queries [found-cold [[] [[?f <- :found-cold]]]] - :sessions [empty-session [any-cold found-cold] {}]} + :sessions [empty-session [any-cold found-cold] {}]} - (let [session (-> empty-session - (insert (->Temperature 10 "MCI") - (->Cold 5)) - fire-rules) + (let [session (-> empty-session + (insert (->Temperature 10 "MCI") + (->Cold 5)) + fire-rules) - results (query session found-cold)] + results (query session found-cold)] - (is (= 1 (count results))) + (is (= 1 (count results))) - (is (= ^{:type found-cold} {:?f {:found true}} - (first results)))))) + (is (= ^{:type found-cold} {:?f {:found true}} + (first results))))) (def locals-shadowing-tester - "Used to demonstrate local shadowing works in `test-rhs-locals-shadowing-vars` below." - :bad) - -;; FIXME: This doesn't work in ClojureScript and it should; it gives a compilation error. -#?(:clj - (def-rules-test test-rhs-locals-shadowing-vars - - {:rules [r1 [[[Temperature]] - (let [{:keys [locals-shadowing-tester]} {:locals-shadowing-tester :good}] - (insert! ^{:type :result} - {:r :r1 - :v locals-shadowing-tester}))] - - r2 [[[Temperature]] - (let [locals-shadowing-tester :good] - (insert! ^{:type :result} - {:r :r2 - :v locals-shadowing-tester}))] - - r3 [[[Temperature]] - (let [[locals-shadowing-tester] [:good]] - (insert! ^{:type :result} - {:r :r3 - :v locals-shadowing-tester}))] - - r4 [[[Temperature]] - (insert-all! (for [_ (range 1) - :let [locals-shadowing-tester :good]] - ^{:type :result} - {:r :r4 - :v locals-shadowing-tester}))]] - - :queries [q [[] [[?r <- :result]]]] - - :sessions [empty-session [r1 r2 r3 r4 q] {}]} - - (is (= (frequencies [{:r :r1 - :v :good} - {:r :r2 - :v :good} - {:r :r3 - :v :good} - {:r :r4 - :v :good}]) - (->> (-> empty-session - (insert (->Temperature 10 "MCI")) - fire-rules - (query q)) - (map :?r) - frequencies))))) - -#?(:clj - (def-rules-test test-qualified-java-introp + "Used to demonstrate local shadowing works in `test-rhs-locals-shadowing-vars` below." + :bad) + +(def-rules-test test-rhs-locals-shadowing-vars + + {:rules [r1 [[[Temperature]] + (let [{:keys [locals-shadowing-tester]} {:locals-shadowing-tester :good}] + (insert! ^{:type :result} + {:r :r1 + :v locals-shadowing-tester}))] + + r2 [[[Temperature]] + (let [locals-shadowing-tester :good] + (insert! ^{:type :result} + {:r :r2 + :v locals-shadowing-tester}))] + + r3 [[[Temperature]] + (let [[locals-shadowing-tester] [:good]] + (insert! ^{:type :result} + {:r :r3 + :v locals-shadowing-tester}))] + + r4 [[[Temperature]] + (insert-all! (for [_ (range 1) + :let [locals-shadowing-tester :good]] + ^{:type :result} + {:r :r4 + :v locals-shadowing-tester}))]] + + :queries [q [[] [[?r <- :result]]]] + + :sessions [empty-session [r1 r2 r3 r4 q] {}]} + + (is (= (frequencies [{:r :r1 + :v :good} + {:r :r2 + :v :good} + {:r :r3 + :v :good} + {:r :r4 + :v :good}]) + (->> (-> empty-session + (insert (->Temperature 10 "MCI")) + fire-rules + (query q)) + (map :?r) + frequencies)))) + +(def-rules-test test-qualified-java-introp + + {:queries [find-string-substring [[] + [[?s <- String (and (<= 2 (count this)) + (.. this (substring 2) toString))]]]] + + :sessions [empty-session [find-string-substring] {}]} - {:queries [find-string-substring [[] - [[?s <- String (and (<= 2 (count this)) - (.. this (substring 2) toString))]]]] - - :sessions [empty-session [find-string-substring] {}]} - - (let [session (-> empty-session - (insert "abc") - fire-rules)] + (let [session (-> empty-session + (insert "abc") + fire-rules)] - (is (= [{:?s "abc"}] - (query session find-string-substring)))))) + (is (= [{:?s "abc"}] + (query session find-string-substring))))) (def-rules-test record-fields-with-munged-names {:queries [q [[] diff --git a/src/test/clojure/clara/test_durability.clj b/src/test/clojure/clara/test_durability.clj index eaa0e166..9eb4a4f2 100644 --- a/src/test/clojure/clara/test_durability.clj +++ b/src/test/clojure/clara/test_durability.clj @@ -14,7 +14,6 @@ [clara.tools.testing-utils :as tu]) (:import [clara.rules.testfacts Temperature] [clara.rules.engine TestNode])) - (use-fixtures :once st/validate-schemas) @@ -34,7 +33,7 @@ ;; cases. (when (is (= expected-fact fact) "The expected and actual must be equal") - + (or (identical? expected-fact fact) (and (is (= (coll? expected-fact) (coll? fact)) @@ -88,7 +87,7 @@ chi "CHI" irk "IRK" ten 10 - twenty 20 + twenty 20 fifty 50 forty 40 thirty 30 @@ -167,13 +166,13 @@ ws50 ws40 ws10] (:all-objs results) - + fired (:fired-session results) {:keys [unpaired-res cold-res hot-res - temp-his-res + temp-his-res temps-under-thresh-res]} (:query-results results) create-serializer (fn [stream] @@ -191,7 +190,7 @@ mem-serializer (->LocalMemorySerializer holder)] ;; Serialize the data. Store the rulebase seperately. This is likely to be the most common usage. - + (d/serialize-rulebase fired rulebase-serializer) (d/serialize-session-state fired @@ -210,14 +209,14 @@ restored (d/deserialize-session-state session-serializer mem-serializer {:base-rulebase restored-rulebase}) - + r-unpaired-res (query restored dr/unpaired-wind-speed) r-cold-res (query restored dr/cold-temp) r-hot-res (query restored dr/hot-temp) r-temp-his-res (query restored dr/temp-his) r-temps-under-thresh-res (query restored dr/temps-under-thresh) - facts @(:holder mem-serializer)] + facts (sort-by hash @(:holder mem-serializer))] (testing "Ensure the queries return same before and after serialization" (is (= (frequencies [{:?ws (dr/->UnpairedWindSpeed ws10)}]) @@ -269,40 +268,40 @@ ;; All of these facts must have an identical? relationship (same object references) ;; as the actual facts being tested against. - expected-facts [temp50 - temp40 - temp30 - temp20 - [temp50 temp40 temp30 temp20] - mci - lax - san - chi - twenty - cold20 - unpaired-ws10 - temp-his - ws50 - ws40 - ws10 - irk - fifty - forty - thirty - thresh50 - temps-under-thresh - hot40 - hot30 - hot50 - [temp40 temp30 temp20]]] - + expected-facts (sort-by hash [temp50 + temp40 + temp30 + temp20 + [temp50 temp40 temp30 temp20] + mci + lax + san + chi + twenty + cold20 + unpaired-ws10 + temp-his + ws50 + ws40 + ws10 + irk + fifty + forty + thirty + thresh50 + temps-under-thresh + hot40 + hot30 + hot50 + [temp40 temp30 temp20]])] + (is (= (count expected-facts) (count facts)) (str "expected facts:" \newline (vec expected-facts) \newline "actual facts:" \newline (vec facts))) - + (doseq [i (range (count expected-facts)) :let [expected-fact (nth expected-facts i) fact (nth facts i)]] @@ -317,7 +316,7 @@ (if deserialize-opts (d/deserialize-rulebase (df/create-session-serializer bais) deserialize-opts) (d/deserialize-rulebase (df/create-session-serializer bais))))))) - + (deftest test-durability-fressian-serde (testing "SerDe of the rulebase along with working memory" (durability-test :fressian)) @@ -334,7 +333,7 @@ init-qresults (:query-results (session-test s)) restored-qresults1 (:query-results (session-test restored1)) restored-qresults2 (:query-results (session-test restored2))] - + (is (= init-qresults restored-qresults1 restored-qresults2))))) @@ -378,7 +377,7 @@ activation-group-sort-fn-called? (volatile! false) fact-type-fn-called? (volatile! false) ancestors-fn-called? (volatile! false) - + opts {:activation-group-fn (fn [x] (vreset! activation-group-fn-called? true) (or (some-> x :props :salience) @@ -394,7 +393,7 @@ (ancestors x))} rulebase (rb-serde orig opts) - + restored (if assemble-with-memory? (d/assemble-restored-session rulebase memory opts) (d/assemble-restored-session rulebase opts))] @@ -424,7 +423,7 @@ ;; Simulate deserializing in an environment without this var by unmapping it. (ns-unmap 'clara.test-durability 'test-compilation-ctx-var) (try - (rb-serde without-compile-ctx nil) + (rb-serde without-compile-ctx {:compiler-cache false}) (is false "Error not thrown when deserializing the rulebase without ctx") (catch Exception e ;; In the event that the compilation context is not retained the original condition of the node will not be present. @@ -434,10 +433,9 @@ (tu/get-all-ex-data e))))) (try - (rb-serde with-compile-ctx nil) + (rb-serde with-compile-ctx {:compiler-cache false}) (is false "Error not thrown when deserializing the rulebase with ctx") (catch Exception e - (is (some #(= (select-keys (:condition %) [:type :constraints]) {:type Long :constraints ['(== this clara.test-durability/test-compilation-ctx-var)]}) diff --git a/src/test/clojure/clara/test_engine.clj b/src/test/clojure/clara/test_engine.clj new file mode 100644 index 00000000..5a61e49e --- /dev/null +++ b/src/test/clojure/clara/test_engine.clj @@ -0,0 +1,76 @@ +(ns clara.test-engine + (:require [clara.rules :refer [mk-session + fire-rules + fire-rules-async + query + defrule defquery + insert-all + insert!]] + [clojure.core.async :refer [go timeout + (go + ( + (async + (! (mk-session 'clara.test-engine :fact-type-fn :type :cache false) + (insert-all fact-seq))] + session)) + +(def session-10000 + (let [fact-seq (repeat 10000 {:type :number + :value 199}) + session (-> (mk-session 'clara.test-engine :fact-type-fn :type) + (insert-all fact-seq))] + session)) + +(deftest parallel-compute-engine-performance-test + (testing "parallel compute with large batch size for non-blocking io - 50 facts - 100 batch size" + (let [result (with-progress-reporting + (quick-benchmark + (-> (! (!Temperature ->Cold ->WindSpeed - ->ColdAndWindy]] - [clojure.test :refer [is deftest run-tests testing use-fixtures]] - [clara.rules.accumulators] - [schema.test :as st]) - (:import [clara.rules.testfacts - Temperature - Cold - WindSpeed - ColdAndWindy])) - - :cljs - (ns clara.test-exists - (:require [clara.rules :refer [fire-rules - insert - insert! - insert-all - insert-unconditional! - retract - query]] - [clara.rules.testfacts :refer [->Temperature Temperature - ->Cold Cold - ->WindSpeed WindSpeed - ->ColdAndWindy ColdAndWindy]] - [clara.rules.accumulators] - [cljs.test] - [schema.test :as st]) - (:require-macros [clara.tools.testing-utils :refer [def-rules-test]] - [cljs.test :refer [is deftest run-tests testing use-fixtures]]))) - -(use-fixtures :once st/validate-schemas #?(:clj tu/opts-fixture)) +(ns clara.test-exists + (:require [clara.tools.testing-utils :refer [def-rules-test] :as tu] + [clara.rules :refer [fire-rules + insert + insert-all + insert-unconditional! + insert! + retract + query]] + + [clara.rules.testfacts :refer [->Temperature ->Cold ->WindSpeed + ->ColdAndWindy]] + [clojure.test :refer [is deftest run-tests testing use-fixtures]] + [clara.rules.accumulators] + [schema.test :as st]) + (:import [clara.rules.testfacts + Temperature + Cold + WindSpeed + ColdAndWindy])) + +(use-fixtures :once st/validate-schemas tu/opts-fixture) (def-rules-test test-simple-exists {:queries [has-windspeed [[] [[:exists [WindSpeed (= ?location location)]]]]] @@ -174,7 +154,7 @@ (def-rules-test test-additional-item-noop {:rules [exists-rule [[[:exists [Temperature (< temperature 0)]]] - (insert-unconditional! (->Cold :freezing))]] + (insert-unconditional! (->Cold :freezing))]] :queries [cold-query [[] [[Cold (= ?t temperature)]]]] diff --git a/src/test/clojure/clara/test_fressian.clj b/src/test/clojure/clara/test_fressian.clj index 994bcceb..6416f753 100644 --- a/src/test/clojure/clara/test_fressian.clj +++ b/src/test/clojure/clara/test_fressian.clj @@ -57,7 +57,7 @@ (testing "set" (test-serde-with-meta #{:x :y} #{:x :y})) - + (testing "vec" (test-serde-with-meta [1 2 3] [1 2 3])) @@ -78,13 +78,13 @@ (test-serde [:x 1] e) (is (instance? clojure.lang.MapEntry (serde e)) "preserves map entry type to be sure to still work with `key` and `val`"))) - + (testing "sym" (test-serde-with-meta 't 't)) (testing "record" (test-serde-with-meta (->Tester 10) (->Tester 10))) - + (testing "sorted collections" (let [ss (sorted-set 1 10) ss-custom (with-meta (sorted-set-by custom-comparator 1 10) diff --git a/src/test/clojure/clara/test_infinite_loops.clj b/src/test/clojure/clara/test_infinite_loops.clj index 67d53a74..ae8ad92a 100644 --- a/src/test/clojure/clara/test_infinite_loops.clj +++ b/src/test/clojure/clara/test_infinite_loops.clj @@ -1,6 +1,7 @@ (ns clara.test-infinite-loops (:require [clojure.test :refer :all] [clara.rules :refer :all] + [clara.rules.dsl :as dsl] [clara.rules.testfacts :refer [->Cold ->Hot ->First ->Second]] [clara.tools.testing-utils :refer [def-rules-test ex-data-maps @@ -9,13 +10,74 @@ assert-ex-data]] [clara.tools.tracing :as tr] [clara.rules.accumulators :as acc] - [clara.tools.loop-detector :as ld]) - (:import [clara.rules.testfacts Cold Hot First Second] + [clara.tools.loop-detector :as ld] + [clojure.core.async :refer [timeout]] + [futurama.core :refer [!Cold nil)))) + result-f (-> (mk-session [cold-rule] :cache false) + (insert (->Cold nil)) + (fire-rules-async))] + (when-not (deref result-f 10 nil) + (async-cancel! result-f)) + (is (thrown? CancellationException (!Cold nil)))) + result-f (-> (mk-session [cold-rule] :cache false) + (insert (->Cold nil)) + (fire-rules-async))] + (when-not (deref result-f 10 nil) + (async-cancel! result-f)) + (is (thrown? CancellationException (!Cold nil)))) + result-f (future + (-> (mk-session [cold-rule] :cache false) + (insert (->Cold nil)) + (fire-rules)))] + (when-not (deref result-f 10 nil) + (async-cancel! result-f)) + (is (thrown? CancellationException (!Cold nil)))) + result-f (future + (-> (mk-session [cold-rule] :cache false) + (insert (->Cold nil)) + (fire-rules)))] + (when-not (deref result-f 10 nil) + (async-cancel! result-f)) + (is (thrown? CancellationException (!Cold nil)) {:salience 1}] @@ -83,7 +144,6 @@ (assert-ex-data {:clara-rules/infinite-loop-suspected true} (fire-rules session)))) - (def-rules-test test-recursive-insertion ;; Test of an infinite loop due to runaway insertions without retractions. @@ -207,6 +267,36 @@ (query first-query))) 21))) +(def-rules-test test-cycle-count-returned + ;; As the name suggests, this is a test to validate that cycle-count is returned on the persistend listener. + {:rules [recursive-rule-with-end [[[First]] + (when (< @side-effect-holder 20) + (do + (insert-unconditional! (->First)) + (swap! side-effect-holder inc)))]] + + :queries [first-query [[] [[?f <- First]]]] + + :sessions [empty-session [recursive-rule-with-end first-query] {}]} + + (reset! side-effect-holder 0) + + (is (= (count (-> (ld/with-loop-detection empty-session 30 :throw-exception) + (insert (->First)) + fire-rules + (query first-query))) + 21)) + + (reset! side-effect-holder 0) + + (is (= (let [^CyclicalRuleListener listener (-> (ld/with-loop-detection empty-session 30 :throw-exception) + (insert (->First)) + fire-rules + (eng/find-listeners (partial instance? CyclicalRuleListener)) + first)] + (.cycles-count listener)) + 20))) + (def-rules-test test-max-cycles-per-fire-rules-call {:rules [recursive-rule-with-end [[[First]] @@ -257,8 +347,8 @@ (insert! (->Cold nil))]] :sessions [empty-session [hot-rule] {}]} - + (assert-ex-data {:clara-rules/max-cycles-exceeded-fn "NOT A FUNCTION"} (ld/with-loop-detection empty-session 3000 "NOT A FUNCTION"))) - + diff --git a/src/test/clojure/clara/test_java.clj b/src/test/clojure/clara/test_java.clj index fa1185ed..c26d8c98 100644 --- a/src/test/clojure/clara/test_java.clj +++ b/src/test/clojure/clara/test_java.clj @@ -6,7 +6,7 @@ (:import [clara.rules.testfacts Temperature WindSpeed Cold ColdAndWindy LousyWeather First Second Third Fourth] [clara.rules QueryResult RuleLoader WorkingMemory])) -(defn- java-namespace-args +(defn- java-namespace-args "The java API expects an arra of strings containing namespace names, so create that." [] (doto (make-array String 2) @@ -24,13 +24,13 @@ (.add (->Temperature -10 "CHI"))) ;; Testing Java interop, so session is a clara.rules.WorkingMemory object. - session (-> (RuleLoader/loadRules (java-namespace-args)) + session (-> (RuleLoader/loadRules (java-namespace-args)) (.insert facts) (.fireRules)) subzero-locs (.query session "clara.other-ruleset/subzero-locations" {}) freezing-locs (.query session "clara.sample-ruleset/freezing-locations" {})] - + (is (= #{"CHI"} (set (map #(.getResult % "?loc") subzero-locs)))) @@ -40,9 +40,9 @@ (deftest query-with-args (let [session (-> (RuleLoader/loadRules (java-namespace-args)) - (.insert [(->Temperature 15 "MCI") - (->Temperature 10 "BOS") - (->Temperature 50 "SFO") + (.insert [(->Temperature 15 "MCI") + (->Temperature 10 "BOS") + (->Temperature 50 "SFO") (->Temperature -10 "CHI")]) (.fireRules)) @@ -51,6 +51,6 @@ (.put "?loc" "CHI")) chicago-temp (.query session "clara.other-ruleset/temp-by-location" java-args)] - + (is (= #{-10} (set (map #(.getResult % "?temp") chicago-temp)))))) diff --git a/src/test/common/clara/test_memory.cljc b/src/test/clojure/clara/test_memory.clj similarity index 76% rename from src/test/common/clara/test_memory.cljc rename to src/test/clojure/clara/test_memory.clj index dc47251d..eb2250b0 100644 --- a/src/test/common/clara/test_memory.cljc +++ b/src/test/clojure/clara/test_memory.clj @@ -1,49 +1,26 @@ -#?(:clj - (ns clara.test-memory - (:require [clara.tools.testing-utils :refer [def-rules-test] :as tu] - [clara.rules :refer [fire-rules - insert - insert-all - insert! - retract - query]] - [clara.rules.testfacts :refer [->Temperature ->Cold ->WindSpeed ->Hot - ->ColdAndWindy ->First ->Second]] - [clojure.test :refer [is deftest run-tests testing use-fixtures]] - [clara.rules.accumulators :as acc] - [schema.test :as st]) - (:import [clara.rules.testfacts - Temperature - Hot - Cold - WindSpeed - ColdAndWindy - First - Second])) - - :cljs - (ns clara.test-memory - (:require [clara.rules :refer [fire-rules - insert - insert! - insert-all - retract - query]] - [clara.rules.testfacts :refer [->Temperature Temperature - ->Cold Cold - ->Hot Hot - ->WindSpeed WindSpeed - ->ColdAndWindy ColdAndWindy - ->First First - ->Second Second]] - [clara.rules.accumulators :as acc] - [clara.tools.testing-utils :as tu] - [cljs.test] - [schema.test :as st]) - (:require-macros [clara.tools.testing-utils :refer [def-rules-test]] - [cljs.test :refer [is deftest run-tests testing use-fixtures]]))) - -(use-fixtures :once st/validate-schemas #?(:clj tu/opts-fixture)) +(ns clara.test-memory + (:require [clara.tools.testing-utils :refer [def-rules-test] :as tu] + [clara.rules :refer [fire-rules + insert + insert-all + insert! + retract + query]] + [clara.rules.testfacts :refer [->Temperature ->Cold ->WindSpeed ->Hot + ->ColdAndWindy ->First ->Second]] + [clojure.test :refer [is deftest run-tests testing use-fixtures]] + [clara.rules.accumulators :as acc] + [schema.test :as st]) + (:import [clara.rules.testfacts + Temperature + Hot + Cold + WindSpeed + ColdAndWindy + First + Second])) + +(use-fixtures :once st/validate-schemas tu/opts-fixture) ;; While the memory is tested through rules and queries, rather than direct unit tests on the memory, ;; the intent of these tests is to create patterns in the engine that cover edge cases and other paths @@ -113,7 +90,6 @@ (is (= n (count (query session cold-query)))))) - (def-rules-test test-many-retract-accumulated-for-same-accumulate-with-join-filter-node {:rules [count-cold-temps [[[Cold (= ?cold-temp temperature)] diff --git a/src/test/common/clara/test_negation.cljc b/src/test/clojure/clara/test_negation.clj similarity index 83% rename from src/test/common/clara/test_negation.cljc rename to src/test/clojure/clara/test_negation.clj index 2bf4eb0e..5bf1851c 100644 --- a/src/test/common/clara/test_negation.cljc +++ b/src/test/clojure/clara/test_negation.clj @@ -1,49 +1,28 @@ -#?(:clj - (ns clara.test-negation - (:require [clara.tools.testing-utils :refer [def-rules-test - side-effect-holder] :as tu] - [clara.rules :refer [fire-rules - insert - insert-all - insert-all! - insert! - retract - query]] - - [clara.rules.testfacts :refer [->Temperature ->Cold ->WindSpeed - ->ColdAndWindy ->LousyWeather]] - [clojure.test :refer [is deftest run-tests testing use-fixtures]] - [clara.rules.accumulators] - [schema.test :as st]) - (:import [clara.rules.testfacts - Temperature - Cold - WindSpeed - ColdAndWindy - LousyWeather])) - - :cljs - (ns clara.test-negation - (:require [clara.rules :refer [fire-rules - insert - insert! - insert-all - insert-all! - retract - query]] - [clara.rules.testfacts :refer [->Temperature Temperature - ->Cold Cold - ->WindSpeed WindSpeed - ->ColdAndWindy ColdAndWindy - ->LousyWeather LousyWeather]] - [clara.rules.accumulators] - [cljs.test] - [schema.test :as st] - [clara.tools.testing-utils :refer [side-effect-holder] :as tu]) - (:require-macros [clara.tools.testing-utils :refer [def-rules-test]] - [cljs.test :refer [is deftest run-tests testing use-fixtures]]))) - -(use-fixtures :once st/validate-schemas #?(:clj tu/opts-fixture)) +(ns clara.test-negation + (:require [clara.tools.testing-utils :refer [def-rules-test + side-effect-holder] :as tu] + [clara.rules :refer [fire-rules + insert + insert-all + insert-all! + insert! + retract + query]] + + [clara.rules.testfacts :refer [->Temperature ->Cold ->WindSpeed + ->ColdAndWindy ->LousyWeather]] + [clojure.test :refer [is deftest run-tests testing use-fixtures]] + [clara.rules.accumulators] + [schema.test :as st]) + (:import [clara.rules.engine ISystemFact] + [clara.rules.testfacts + Temperature + Cold + WindSpeed + ColdAndWindy + LousyWeather])) + +(use-fixtures :once st/validate-schemas tu/opts-fixture) (def-rules-test test-exists-inside-boolean-conjunction-and-disjunction @@ -142,25 +121,25 @@ ;; The cold fact should be retracted because inserting this ;; triggers an insert that matches the negation. - (is (empty? (-> empty-session - (insert (->WindSpeed 100 "MCI")) - (fire-rules) - (query cold-query)))) + (is (empty? (-> empty-session + (insert (->WindSpeed 100 "MCI")) + (fire-rules) + (query cold-query)))) ;; The cold fact should exist again because we are indirectly retracting ;; the fact that matched the negation originially - (is (= [{:?c (->Cold 0)}] - (-> empty-session - (insert (->WindSpeed 100 "MCI")) - (fire-rules) - (retract (->WindSpeed 100 "MCI")) - (fire-rules) - (query cold-query)))))) + (is (= [{:?c (->Cold 0)}] + (-> empty-session + (insert (->WindSpeed 100 "MCI")) + (fire-rules) + (retract (->WindSpeed 100 "MCI")) + (fire-rules) + (query cold-query)))))) (def-rules-test test-negation-with-other-conditions {:queries [windy-but-not-cold-query [[] [[WindSpeed (> windspeed 30) (= ?w windspeed)] - [:not [ Temperature (< temperature 20)]]]]] + [:not [Temperature (< temperature 20)]]]]] :sessions [empty-session [windy-but-not-cold-query] {}]} @@ -265,8 +244,7 @@ (not facts-expected?) (not-empty (query session object-query))) "If the object query returns nothing the setup of this test is invalid") - (not-any? (fn [fact] #?(:clj (instance? clara.rules.engine.ISystemFact fact) - :cljs (isa? :clara.rules.engine/system-type fact))) + (not-any? (fn [fact] (instance? ISystemFact fact)) (as-> session x (query x object-query) (map :?o x))))] diff --git a/src/test/common/clara/test_node_sharing.cljc b/src/test/clojure/clara/test_node_sharing.clj similarity index 81% rename from src/test/common/clara/test_node_sharing.cljc rename to src/test/clojure/clara/test_node_sharing.clj index 1a192c7f..a4022b89 100644 --- a/src/test/common/clara/test_node_sharing.cljc +++ b/src/test/clojure/clara/test_node_sharing.clj @@ -1,47 +1,26 @@ -#?(:clj - (ns clara.test-node-sharing - (:require [clara.tools.testing-utils :refer [def-rules-test] :as tu] - [clara.rules :refer [fire-rules - insert - insert-all - insert-unconditional! - insert! - retract - query]] - - [clara.rules.testfacts :refer [->Temperature ->Cold ->WindSpeed - ->ColdAndWindy]] - [clojure.test :refer [is deftest run-tests testing use-fixtures]] - [clara.rules.accumulators] - [schema.test :as st]) - (:import [clara.rules.testfacts - Temperature - Cold - WindSpeed - ColdAndWindy - WindSpeed])) - - :cljs - (ns clara.test-node-sharing - (:require [clara.rules :refer [fire-rules - insert - insert! - insert-all - insert-unconditional! - retract - query]] - [clara.rules.testfacts :refer [->Temperature Temperature - ->Cold Cold - ->WindSpeed WindSpeed - ->ColdAndWindy ColdAndWindy]] - [clara.rules.accumulators] - [cljs.test] - [schema.test :as st] - [clara.tools.testing-utils :as tu]) - (:require-macros [clara.tools.testing-utils :refer [def-rules-test]] - [cljs.test :refer [is deftest run-tests testing use-fixtures]]))) - -(use-fixtures :once st/validate-schemas #?(:clj tu/opts-fixture) tu/side-effect-holder-fixture) +(ns clara.test-node-sharing + (:require [clara.tools.testing-utils :refer [def-rules-test] :as tu] + [clara.rules :refer [fire-rules + insert + insert-all + insert-unconditional! + insert! + retract + query]] + + [clara.rules.testfacts :refer [->Temperature ->Cold ->WindSpeed + ->ColdAndWindy]] + [clojure.test :refer [is deftest run-tests testing use-fixtures]] + [clara.rules.accumulators] + [schema.test :as st]) + (:import [clara.rules.testfacts + Temperature + Cold + WindSpeed + ColdAndWindy + WindSpeed])) + +(use-fixtures :once st/validate-schemas tu/opts-fixture tu/side-effect-holder-fixture) ;; See issue 433 for more information (def-rules-test test-or-sharing-same-condition @@ -95,7 +74,6 @@ (is (= (query session c-query) [{:?c {:fact-type ::c}}])))) - ;; FIXME: Log an issue for this bug and uncomment when it is resolved. Since an :or ;; condition is essentially creating two rules I'd expect this to insert twice. (comment @@ -104,8 +82,7 @@ [:and [:or [::a] [::b]] - [::d] - ] + [::d]] [:and [::a] [::d]]]] @@ -215,7 +192,6 @@ (is (= (set (query session e-query)) #{})))) - (def-rules-test test-sharing-simple-condition-followed-by-or {:rules [cold-and-windy-rule [[[WindSpeed (> windspeed 20) (do (swap! tu/side-effect-holder inc) diff --git a/src/test/clojure/clara/test_performance_optimizations.clj b/src/test/clojure/clara/test_performance_optimizations.clj new file mode 100644 index 00000000..927db1e8 --- /dev/null +++ b/src/test/clojure/clara/test_performance_optimizations.clj @@ -0,0 +1,45 @@ +;; These tests validate that operations that the rules engine should optimize +;; away are in fact optimized away. The target here is not the actual execution time, +;; which will vary per system, but verification that the action operations in question are not performed. +(ns clara.test-performance-optimizations + (:require [clara.tools.testing-utils :refer [def-rules-test + side-effect-holder] :as tu] + [clara.rules :refer [fire-rules + insert + insert! + query]] + + [clara.rules.testfacts :refer [->Cold ->ColdAndWindy]] + [clojure.test :refer [is deftest run-tests testing use-fixtures]] + [clara.rules.accumulators] + [schema.test :as st]) + (:import [clara.rules.testfacts + Cold + ColdAndWindy])) + +(use-fixtures :once st/validate-schemas tu/opts-fixture) +(use-fixtures :each tu/side-effect-holder-fixture) + +(defmacro true-if-binding-absent + [] + (not (contains? &env '?unused-binding))) + +;; See issue https://github.com/cerner/clara-rules/issues/383 +;; This validates that we don't create let bindings for binding +;; variables that aren't used. Doing so both imposes runtime costs +;; and increases the size of the generated code that must be evaluated. +(def-rules-test test-unused-rhs-binding-not-bound + + {:rules [cold-windy-rule [[[ColdAndWindy (= ?used-binding temperature) (= ?unused-binding windspeed)]] + (when (true-if-binding-absent) + (insert! (->Cold ?used-binding)))]] + + :queries [cold-query [[] [[Cold (= ?c temperature)]]]] + + :sessions [empty-session [cold-windy-rule cold-query] {}]} + + (is (= [{:?c 0}] + (-> empty-session + (insert (->ColdAndWindy 0 0)) + fire-rules + (query cold-query))))) diff --git a/src/test/common/clara/test_queries.cljc b/src/test/clojure/clara/test_queries.clj similarity index 58% rename from src/test/common/clara/test_queries.cljc rename to src/test/clojure/clara/test_queries.clj index a181febc..f10b7622 100644 --- a/src/test/common/clara/test_queries.cljc +++ b/src/test/clojure/clara/test_queries.clj @@ -1,29 +1,17 @@ -#?(:clj - (ns clara.test-queries - (:require [clara.tools.testing-utils :refer [def-rules-test - side-effect-holder] :as tu] - [clara.rules :refer [fire-rules - insert - query]] - - [clara.rules.testfacts :refer [->Temperature]] - [clojure.test :refer [is deftest run-tests testing use-fixtures]] - [schema.test :as st]) - (:import [clara.rules.testfacts - Temperature])) - - :cljs - (ns clara.test-queries - (:require [clara.rules :refer [fire-rules - insert - query]] - [clara.rules.testfacts :refer [->Temperature Temperature]] - [cljs.test] - [schema.test :as st]) - (:require-macros [clara.tools.testing-utils :refer [def-rules-test]] - [cljs.test :refer [is deftest run-tests testing use-fixtures]]))) - -(use-fixtures :once st/validate-schemas #?(:clj tu/opts-fixture)) +(ns clara.test-queries + (:require [clara.tools.testing-utils :refer [def-rules-test + side-effect-holder] :as tu] + [clara.rules :refer [fire-rules + insert + query]] + + [clara.rules.testfacts :refer [->Temperature]] + [clojure.test :refer [is deftest run-tests testing use-fixtures]] + [schema.test :as st]) + (:import [clara.rules.testfacts + Temperature])) + +(use-fixtures :once st/validate-schemas tu/opts-fixture) (def-rules-test test-simple-query @@ -69,5 +57,5 @@ (is (= #{{:?l "ORD" :?t 10}} (set (query session cold-query :?l "ORD")))))) - + diff --git a/src/test/clojure/clara/test_rhs_retract.clj b/src/test/clojure/clara/test_rhs_retract.clj new file mode 100644 index 00000000..74e9d326 --- /dev/null +++ b/src/test/clojure/clara/test_rhs_retract.clj @@ -0,0 +1,44 @@ +(ns clara.test-rhs-retract + (:require [clara.tools.testing-utils :refer [def-rules-test] :as tu] + [clara.rules :refer [fire-rules + insert + insert-all + insert! + retract + query + retract!]] + + [clara.rules.testfacts :refer [->Temperature ->Cold]] + [clojure.test :refer [is deftest run-tests testing use-fixtures]] + [clara.rules.accumulators] + [schema.test :as st]) + (:import [clara.rules.testfacts + Temperature + Cold])) + +(use-fixtures :once st/validate-schemas tu/opts-fixture) + +(def-rules-test test-retract! + + {:rules [not-cold-rule [[[Temperature (> temperature 50)]] + (retract! (->Cold 20))]] + + :queries [cold-query [[] + [[Cold (= ?t temperature)]]]] + + :sessions [empty-session [not-cold-rule cold-query] {}]} + + (let [session (-> empty-session + (insert (->Cold 20)) + (fire-rules))] + + ;; The session should contain our initial cold reading. + (is (= #{{:?t 20}} + (set (query session cold-query)))) + + ;; Insert a higher temperature and ensure the cold fact was retracted. + (is (= #{} + (set (query (-> session + (insert (->Temperature 80 "MCI")) + (fire-rules)) + cold-query)))))) diff --git a/src/test/clojure/clara/test_rules.clj b/src/test/clojure/clara/test_rules.clj index 1d2ea810..ab653094 100644 --- a/src/test/clojure/clara/test_rules.clj +++ b/src/test/clojure/clara/test_rules.clj @@ -15,9 +15,12 @@ [clojure.walk :as walk] [clara.sample-ruleset-seq :as srs] [clara.order-ruleset :as order-rules] + [clojure.core.cache :refer [CacheProtocol]] + [clojure.core.cache.wrapped :as cache] [schema.test] [schema.core :as sc] - [clara.tools.testing-utils :as tu :refer [assert-ex-data]]) + [clara.tools.testing-utils :as tu :refer [assert-ex-data]] + [clara.rules.platform :as platform]) (:import [clara.rules.testfacts Temperature WindSpeed Cold Hot TemperatureHistory ColdAndWindy LousyWeather First Second Third Fourth FlexibleFields] [clara.rules.engine @@ -58,16 +61,16 @@ (defn average-value "Test accumulator that returns the average of a field" [field] - (accumulate - :initial-value [0 0] - :reduce-fn (fn [[value count] item] - [(+ value (field item)) (inc count)]) - :combine-fn (fn [[value1 count1] [value2 count2]] - [(+ value1 value2) (+ count1 count2)]) - :retract-fn identity-retract - :convert-return-fn (fn [[value count]] (if (= 0 count) - nil - (/ value count))))) + (acc/accum + {:initial-value [0 0] + :reduce-fn (fn [[value count] item] + [(+ value (field item)) (inc count)]) + :combine-fn (fn [[value1 count1] [value2 count2]] + [(+ value1 value2) (+ count1 count2)]) + :retract-fn identity-retract + :convert-return-fn (fn [[value count]] (if (= 0 count) + nil + (/ value count)))})) (deftest test-negation-with-complex-retractions (let [;; Non-blocked rule, where "blocked" means there is a @@ -139,8 +142,7 @@ (let [all-temps-are-max (dsl/parse-query [] [[?t <- (acc/max :temperature) :from [Temperature]] - [:not [Temperature (< temperature ?t)]] - ]) + [:not [Temperature (< temperature ?t)]]]) session (mk-session [all-temps-are-max])] @@ -276,11 +278,10 @@ (deftest test-disjunction-with-nested-and - (let [really-cold-or-cold-and-windy (dsl/parse-query [] [[:or [Temperature (< temperature 0) (= ?t temperature)] - [:and [Temperature (< temperature 20) (= ?t temperature)] - [WindSpeed (> windspeed 30) (= ?w windspeed)]]]]) + [:and [Temperature (< temperature 20) (= ?t temperature)] + [WindSpeed (> windspeed 30) (= ?w windspeed)]]]]) rulebase [really-cold-or-cold-and-windy] @@ -361,14 +362,13 @@ {:type Temperature :constraints ['(> 2 1)]} {:type Temperature :constraints ['(> 3 2)]} {:type Temperature :constraints ['(> 4 3)]}] - (com/to-dnf - [:or - {:type Temperature :constraints ['(> 2 1)]} - {:type Temperature :constraints ['(> 3 2)]} - {:type Temperature :constraints ['(> 4 3)]}]))) - + (com/to-dnf + [:or + {:type Temperature :constraints ['(> 2 1)]} + {:type Temperature :constraints ['(> 3 2)]} + {:type Temperature :constraints ['(> 4 3)]}]))) - ;; Test simple disjunction with nested conjunction. +;; Test simple disjunction with nested conjunction. (is (= [:or {:type Temperature :constraints ['(> 2 1)]} [:and @@ -441,10 +441,10 @@ {:type Temperature :constraints ['(> 4 3)]}]]]))) (is (= [:or - {:type Temperature :constraints ['(> 2 1)]} - [:and - {:type Temperature :constraints ['(> 3 2)]} - {:type Temperature :constraints ['(> 4 3)]}]] + {:type Temperature :constraints ['(> 2 1)]} + [:and + {:type Temperature :constraints ['(> 3 2)]} + {:type Temperature :constraints ['(> 4 3)]}]] (com/to-dnf [:and @@ -519,14 +519,14 @@ (defquery cold-query [:?l] [Temperature (< temperature 50) - (= ?t temperature) - (= ?l location)]) + (= ?t temperature) + (= ?l location)]) (defquery hot-query [?l] [Temperature (>= temperature 50) - (= ?t temperature) - (= ?l location)]) + (= ?t temperature) + (= ?l location)]) (deftest test-defquery (let [session (-> (mk-session [cold-query hot-query]) @@ -617,12 +617,12 @@ (insert (->WindSpeed 45 "MCI")) (fire-rules) (query sample/find-lousy-weather)))) - (str "Failed to find LousyWeather using sample-ruleset namespace " sample-ruleset-ns)))) + (str "Failed to find LousyWeather using sample-ruleset namespace " sample-ruleset-ns)))) (deftest test-mark-as-fired (let [rule-output (atom nil) cold-rule (dsl/parse-rule [[Temperature (< temperature 20)]] - (reset! rule-output ?__token__) ) + (reset! rule-output ?__token__)) session (-> (mk-session [cold-rule]) (insert (->Temperature 10 "MCI")) @@ -644,7 +644,6 @@ (is (has-fact? @rule-output (->Temperature 10 "MCI"))))) - (deftest test-chained-inference (let [item-query (dsl/parse-query [] [[?item <- Fourth]]) @@ -695,7 +694,7 @@ fire-rules)] ;; Finds two temperatures such that t1 is less than t2. - (is (= #{ {:?t1 10, :?t2 15}} + (is (= #{{:?t1 10, :?t2 15}} (set (query session distinct-temps-query)))))) (deftest test-test-in-negation @@ -724,12 +723,12 @@ (deftest test-empty-test-condition (let [exception-data {:line 123 :column 456}] (is (assert-ex-data - exception-data - (dsl/parse-query* - [] - [[:test]] - {} - exception-data))))) + exception-data + (dsl/parse-query* + [] + [[:test]] + {} + exception-data))))) (deftest test-multi-insert-retract @@ -753,7 +752,6 @@ (fire-rules) (query sample/freezing-locations))))) - (let [session (-> (mk-session 'clara.sample-ruleset) (insert (->Temperature 15 "MCI")) (insert (->WindSpeed 45 "MCI")) @@ -769,14 +767,13 @@ (deftest test-no-loop (let [reduce-temp (dsl/parse-rule [[?t <- Temperature (> temperature 0) (= ?v temperature)]] - (do - (retract! ?t) - (insert! (->Temperature (- ?v 1) "MCI"))) - {:no-loop true}) + (do + (retract! ?t) + (insert! (->Temperature (- ?v 1) "MCI"))) + {:no-loop true}) temp-query (dsl/parse-query [] [[Temperature (= ?t temperature)]]) - session (-> (mk-session [reduce-temp temp-query]) (insert (->Temperature 10 "MCI")) (fire-rules))] @@ -829,7 +826,6 @@ ;; Only one reduced temperature should be present. (is (= [{:?t 9}] (query session temp-query))))) - ;; Test behavior discussed in https://github.com/cerner/clara-rules/issues/35 (deftest test-identical-facts (let [ident-query (dsl/parse-query [] [[?t1 <- Temperature (= ?loc location)] @@ -850,8 +846,7 @@ ;; The inserted facts are identical, so there cannot be a non-identicial match. (is (empty? (query session ident-query))) - - ;; Duplications should have two matches, since either fact can bind to either condition. +;; Duplications should have two matches, since either fact can bind to either condition. (is (= [{:?t1 #clara.rules.testfacts.Temperature{:temperature 15, :location "MCI"} :?t2 #clara.rules.testfacts.Temperature{:temperature 15, :location "MCI"} :?loc "MCI"} @@ -860,7 +855,6 @@ :?loc "MCI"}] (query session-with-dups ident-query))))) - ;; An EDN string for testing. This would normally be stored in an external file. The structure simply needs to be a ;; sequence of maps matching the clara.rules.schema/Production schema. (def external-rules "[{:name \"cold-query\", :params #{:?l}, :lhs [{:type clara.rules.testfacts.Temperature, :constraints [(< temperature 50) (= ?t temperature) (= ?l location)]}]}]") @@ -884,18 +878,17 @@ (is (= #{{:?l "ORD" :?t 10}} (set (query session "cold-query" :?l "ORD")))))) - (defsession my-session 'clara.sample-ruleset) (deftest test-defsession (is (= #{{:?loc "MCI"} {:?loc "BOS"}} - (set (-> my-session - (insert (->Temperature 15 "MCI")) - (insert (->Temperature 22 "BOS")) - (insert (->Temperature 50 "SFO")) - fire-rules - (query sample/freezing-locations))))) + (set (-> my-session + (insert (->Temperature 15 "MCI")) + (insert (->Temperature 22 "BOS")) + (insert (->Temperature 50 "SFO")) + fire-rules + (query sample/freezing-locations))))) (let [session (-> (mk-session 'clara.sample-ruleset) (insert (->Temperature 15 "MCI")) @@ -932,14 +925,61 @@ ;; The special ancestor query should match everything since our trivial ;; ancestry function treats :my-ancestor as an ancestor of everything. - (is (= #{{:?result (->Temperature 15 "MCI") } - {:?result (->Temperature 10 "MCI") } - {:?result (->Temperature 80 "MCI") }} + (is (= #{{:?result (->Temperature 15 "MCI")} + {:?result (->Temperature 10 "MCI")} + {:?result (->Temperature 80 "MCI")}} (set (query session special-ancestor-query)))) ;; There shouldn't be anything that matches our typical ancestor here. (is (empty? (query session type-ancestor-query))))) +(defhierarchy test-hierarchy + Temperature :my/parent + :my/parent :my/ancestor) + +(deftest test-defhierarchy + (is (= test-hierarchy + (-> (make-hierarchy) + (derive Temperature :my/parent) + (derive :my/parent :my/ancestor))))) + +(deftest test-load-hierarchies + (is (contains? (set (com/load-source 'clara.test-rules)) test-hierarchy))) + +(deftest test-override-hierarchy + (testing "via hierarchy options" + (let [special-ancestor-query (dsl/parse-query [] [[?result <- :my/ancestor]]) + type-ancestor-query (dsl/parse-query [] [[?result <- Temperature]]) + session (-> (mk-session [special-ancestor-query type-ancestor-query] :hierarchy test-hierarchy) + (insert (->Temperature 15 "MCI")) + (insert (->Temperature 10 "MCI")) + (insert (->Temperature 80 "MCI")) + fire-rules)] + + ;; The special ancestor query should match everything since our hierarchy + ;; derives the Temperature class as :my/ancestor. + (is (= #{{:?result (->Temperature 15 "MCI")} + {:?result (->Temperature 10 "MCI")} + {:?result (->Temperature 80 "MCI")}} + (set (query session special-ancestor-query)) + (set (query session type-ancestor-query)))))) + (testing "via hierarchy params" + (let [special-ancestor-query (dsl/parse-query [] [[?result <- :my/ancestor]]) + type-ancestor-query (dsl/parse-query [] [[?result <- Temperature]]) + session (-> (mk-session [special-ancestor-query type-ancestor-query test-hierarchy]) + (insert (->Temperature 15 "MCI")) + (insert (->Temperature 10 "MCI")) + (insert (->Temperature 80 "MCI")) + fire-rules)] + + ;; The special ancestor query should match everything since our hierarchy + ;; derives the Temperature class as :my/ancestor. + (is (= #{{:?result (->Temperature 15 "MCI")} + {:?result (->Temperature 10 "MCI")} + {:?result (->Temperature 80 "MCI")}} + (set (query session special-ancestor-query)) + (set (query session type-ancestor-query))))))) + (deftest test-shared-condition (let [cold-query (dsl/parse-query [] [[Temperature (< temperature 20) (= ?t temperature)]]) cold-windy-query (dsl/parse-query [] [[Temperature (< temperature 20) (= ?t temperature)] @@ -974,10 +1014,10 @@ (deftest test-extract-simple-test (let [distinct-temps-query (dsl/parse-query [] [[Temperature (< temperature 20) - (= ?t1 temperature)] + (= ?t1 temperature)] [Temperature (< temperature 20) - (= ?t2 temperature) + (= ?t2 temperature) (< ?t1 temperature)]]) session (-> (mk-session [distinct-temps-query]) @@ -987,15 +1027,15 @@ fire-rules)] ;; Finds two temperatures such that t1 is less than t2. - (is (= #{ {:?t1 10, :?t2 15}} + (is (= #{{:?t1 10, :?t2 15}} (set (query session distinct-temps-query)))))) (deftest test-extract-nested-test (let [distinct-temps-query (dsl/parse-query [] [[Temperature (< temperature 20) - (= ?t1 temperature)] + (= ?t1 temperature)] [Temperature (< temperature 20) - (= ?t2 temperature) + (= ?t2 temperature) (< (- ?t1 0) temperature)]]) session (-> (mk-session [distinct-temps-query]) @@ -1005,10 +1045,9 @@ fire-rules)] ;; Finds two temperatures such that t1 is less than t2. - (is (= #{ {:?t1 10, :?t2 15}} + (is (= #{{:?t1 10, :?t2 15}} (set (query session distinct-temps-query)))))) - ;; External structure to ensure that salience works with defrule as well. (def salience-rule-output (atom [])) @@ -1031,12 +1070,10 @@ [:numeric-greatest-sort :salience-group :forward-order] [:numeric-greatest-sort :neg-salience-group :backward-order] - [:boolean-greatest-sort :default-group :forward-order] [:boolean-greatest-sort :salience-group :forward-order] [:boolean-greatest-sort :neg-salience-group :backward-order] - [:numeric-least-sort :default-group :backward-order] [:numeric-least-sort :salience-group :backward-order] [:numeric-least-sort :neg-salience-group :forward-order] @@ -1051,12 +1088,12 @@ :props {:salience 100}) rule2 (assoc - (dsl/parse-rule [[Temperature ]] + (dsl/parse-rule [[Temperature]] (swap! salience-rule-output conj 50)) :props {:salience 50}) rule3 (assoc - (dsl/parse-rule [[Temperature ]] + (dsl/parse-rule [[Temperature]] (swap! salience-rule-output conj 0)) :props {:salience 0}) @@ -1109,61 +1146,61 @@ test-fail-str))))))) (deftest test-negation-with-extracted-test - (let [colder-temp (dsl/parse-rule [[Temperature (= ?t temperature)] - [:not [Cold (or (< temperature ?t) - (< temperature 0))]]] + (let [colder-temp (dsl/parse-rule [[Temperature (= ?t temperature)] + [:not [Cold (or (< temperature ?t) + (< temperature 0))]]] (insert! ^{:type :found-colder} {:found true})) - find-colder (dsl/parse-query [] [[?f <- :found-colder]]) + find-colder (dsl/parse-query [] [[?f <- :found-colder]]) - session (-> (mk-session [colder-temp find-colder] :cache false))] + session (-> (mk-session [colder-temp find-colder] :cache false))] ;; Test no token. - (is (empty? (-> session - (insert (->Cold 11)) - (fire-rules) - (query find-colder)))) + (is (empty? (-> session + (insert (->Cold 11)) + (fire-rules) + (query find-colder)))) ;; Test simple insertion. - (is (= [{:?f {:found true}}] - (-> session - (insert (->Temperature 10 "MCI")) - (insert (->Cold 11)) - (fire-rules) - (query find-colder)))) + (is (= [{:?f {:found true}}] + (-> session + (insert (->Temperature 10 "MCI")) + (insert (->Cold 11)) + (fire-rules) + (query find-colder)))) ;; Test insertion with right-hand match first. - (is (= [{:?f {:found true}}] - (-> session - (insert (->Cold 11)) - (insert (->Temperature 10 "MCI")) - (fire-rules) - (query find-colder)))) + (is (= [{:?f {:found true}}] + (-> session + (insert (->Cold 11)) + (insert (->Temperature 10 "MCI")) + (fire-rules) + (query find-colder)))) ;; Test no fact matching not. - (is (= [{:?f {:found true}}] - (-> session - (insert (->Temperature 10 "MCI")) - (fire-rules) - (query find-colder)))) + (is (= [{:?f {:found true}}] + (-> session + (insert (->Temperature 10 "MCI")) + (fire-rules) + (query find-colder)))) ;; Test violate negation. - (is (empty? (-> session - (insert (->Cold 9)) - (insert (->Temperature 10 "MCI")) - (fire-rules) - (query find-colder)))) + (is (empty? (-> session + (insert (->Cold 9)) + (insert (->Temperature 10 "MCI")) + (fire-rules) + (query find-colder)))) ;; Test violate negation alternate order. - (is (empty? (-> session - (insert (->Temperature 10 "MCI")) - (insert (->Cold 9)) - (fire-rules) - (query find-colder)))) + (is (empty? (-> session + (insert (->Temperature 10 "MCI")) + (insert (->Cold 9)) + (fire-rules) + (query find-colder)))) ;; Test retract violation. - (is (= [{:?f {:found true}}] + (is (= [{:?f {:found true}}] (-> session (insert (->Cold 9)) (insert (->Temperature 10 "MCI")) @@ -1174,23 +1211,23 @@ ;; Test only partial retraction of violation, ;; ensuring the remaining violation holds. - (is (empty? (-> session - (insert (->Cold 9)) - (insert (->Cold 9)) - (insert (->Temperature 10 "MCI")) - (fire-rules) - (retract (->Cold 9)) - (fire-rules) - (query find-colder)))) + (is (empty? (-> session + (insert (->Cold 9)) + (insert (->Cold 9)) + (insert (->Temperature 10 "MCI")) + (fire-rules) + (retract (->Cold 9)) + (fire-rules) + (query find-colder)))) ;; Test violate negation after success. - (is (empty? (-> session - (insert (->Cold 11)) - (insert (->Temperature 10 "MCI")) - (fire-rules) - (insert (->Cold 9)) - (fire-rules) - (query find-colder)))))) + (is (empty? (-> session + (insert (->Cold 11)) + (insert (->Temperature 10 "MCI")) + (fire-rules) + (insert (->Cold 9)) + (fire-rules) + (query find-colder)))))) ;; TODO: Move this once it succeeds with def-rules-test. The def-rules-test macro may ;; be stripping the metadata somewhere. @@ -1257,29 +1294,29 @@ (let [accum-condition (dsl/parse-query [] [[?ts <- (acc/all) :from [Temperature (and ?bogus (< ?bogus temperature))]]]) negation-condition (dsl/parse-query [] - [[:not [WindSpeed (not= ?invalid location)]]]) + [[:not [WindSpeed (not= ?invalid location)]]]) test-condition (dsl/parse-query [] - [[:test (< ?missing 10)]]) + [[:test (< ?missing 10)]]) multi-conditions (dsl/parse-query [] - [[Temperature (= ?temp temperature) - (= ?loc location)] - [Temperature (= ?loc location) - (< ?temp temperature)] - [Cold (< ?extra1 ?temp ?extra2)]]) + [[Temperature (= ?temp temperature) + (= ?loc location)] + [Temperature (= ?loc location) + (< ?temp temperature)] + [Cold (< ?extra1 ?temp ?extra2)]]) nested-conditions (dsl/parse-query [] [[?t <- Temperature (= ?temp temperature) - (= ?loc location)] - [Cold (= ?temp temperature) + (= ?loc location)] + [Cold (= ?temp temperature) ;; Demonstrating using an available :fact-binding - (some? (:location ?t)) - (and (< ?unbound temperature 10))]]) + (some? (:location ?t)) + (and (< ?unbound temperature 10))]]) nested-accum-conditions (dsl/parse-query [] [[Temperature (= ?loc location)] [?ts <- (acc/all) :from [Temperature (= ?loc location) (< ?invalid temperature)]]]) bool-conditions (dsl/parse-query [] [[?t <- Temperature (= ?temp temperature) - (= ?loc location)] + (= ?loc location)] [:or [Cold (= ?temp temperature) @@ -1322,8 +1359,8 @@ rule {:name "clara.test-destructured-binding/test-destructured-binding" :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)]}] + :type :foo + :constraints [(= e 1) (= v ?value)]}] :rhs '(reset! rule-output ?value)}] (-> (mk-session [rule] :fact-type-fn second) @@ -1361,8 +1398,8 @@ :lhs '[{:type :test :constraints []}] :rhs '(clara.rules/insert! ^{:type :result} - {:r :r1 - :v all-rules})} + {:r :r1 + :v all-rules})} ;; However, rule structures are not required to specific a :ns-name if ;; they do not need them. This would be safe if the :rhs form already ;; had qualified symbols used, which may typically be the case for @@ -1371,8 +1408,8 @@ :lhs '[{:type :test :constraints []}] :rhs `(insert! ^{:type :result} - {:r :r2 - :v locals-shadowing-tester})} + {:r :r2 + :v locals-shadowing-tester})} q (dsl/parse-query [] [[?r <- :result]])] (is (= #{{:r :r1 :v srs/all-rules} @@ -1433,8 +1470,8 @@ (let [q (dsl/parse-query [] ;; Make two conditions that are very similar, but differ ;; where a nil will be compared to something else. - [[(accumulate :retract-fn identity-retract :reduce-fn (fn [x y] nil)) :from [Temperature]] - [(accumulate :retract-fn identity-retract :reduce-fn (fn [x y] 10)) :from [Temperature]]]) + [[(acc/accum {:retract-fn identity-retract :reduce-fn (fn [x y] nil)}) :from [Temperature]] + [(acc/accum {:retract-fn identity-retract :reduce-fn (fn [x y] 10)}) :from [Temperature]]]) s (mk-session [q])] ;; Mostly just ensuring the rulebase was compiled successfully. @@ -1587,40 +1624,67 @@ "s3 res: " (vec (q-res s2)) \newline)))) (deftest test-equivalent-rule-sources-caching - (is (instance? clojure.lang.IAtom @#'com/session-cache) + (is (and (instance? clojure.lang.IAtom (-> #'com/default-session-cache deref)) + (satisfies? CacheProtocol (-> #'com/default-session-cache deref deref))) "Enforce that this test is revisited if the cache structure (an implementation detail) is changed. This test should have a clean cache but should also not impact the global cache, which requires resetting the cache for the duration of this test.") - - (let [original-cache (-> #'com/session-cache deref deref) - _ (reset! @#'com/session-cache {}) - s1 (mk-session [test-rule] :cache false) - s2 (mk-session [test-rule]) - s3 (mk-session [test-rule test-rule]) - s4 (mk-session [test-rule] [test-rule]) - - ;; Since functions use reference equality create a single function instance - ;; to test reuse when options are the same. - alternate-alpha-fn (constantly Object) - s5 (mk-session [test-rule] :fact-type-fn alternate-alpha-fn :cache false) - s6 (mk-session [test-rule] :fact-type-fn alternate-alpha-fn) - s7 (mk-session [test-rule test-rule] :fact-type-fn alternate-alpha-fn) - s8 (mk-session [test-rule cold-query] :fact-type-fn alternate-alpha-fn) - - ;; Find all distinct references, with distinctness determined by reference equality. - ;; If the reference to a session is identical to a previous session we infer that - ;; the session was the result of a cache hit; if the reference is not identical to - ;; a previous session it is the result of a cache miss. - distinct-sessions (reduce (fn [existing new] - (if-not (some (partial identical? new) - existing) - (conj existing new) - existing)) - [] - [s1 s2 s3 s4 s5 s6 s7 s8])] - (is (= distinct-sessions - [s1 s2 s5 s6 s8])) - (reset! @#'com/session-cache original-cache))) + (testing "using default caching" + (com/clear-session-cache!) + (let [s1 (mk-session [test-rule] :cache false) + s2 (mk-session [test-rule]) + s3 (mk-session [test-rule test-rule]) + s4 (mk-session [test-rule] [test-rule]) + + ;; Since functions use reference equality create a single function instance + ;; to test reuse when options are the same. + alternate-alpha-fn (constantly Object) + s5 (mk-session [test-rule] :fact-type-fn alternate-alpha-fn :cache false) + s6 (mk-session [test-rule] :fact-type-fn alternate-alpha-fn) + s7 (mk-session [test-rule test-rule] :fact-type-fn alternate-alpha-fn) + s8 (mk-session [test-rule cold-query] :fact-type-fn alternate-alpha-fn) + + ;; Find all distinct references, with distinctness determined by reference equality. + ;; If the reference to a session is identical to a previous session we infer that + ;; the session was the result of a cache hit; if the reference is not identical to + ;; a previous session it is the result of a cache miss. + distinct-sessions (reduce (fn [existing new] + (if-not (some (partial identical? new) + existing) + (conj existing new) + existing)) + [] + [s1 s2 s3 s4 s5 s6 s7 s8])] + (is (= distinct-sessions + [s1 s2 s5 s6 s8])))) + (testing "using custom cache" + (let [cache (cache/ttl-cache-factory {} :ttl 30000) + s1 (mk-session [test-rule] :cache false) + s2 (mk-session [test-rule] :cache cache) + s3 (mk-session [test-rule test-rule] :cache cache) + s4 (mk-session [test-rule] [test-rule] :cache cache) + + ;; Since functions use reference equality create a single function instance + ;; to test reuse when options are the same. + alternate-alpha-fn (constantly Object) + s5 (mk-session [test-rule] :fact-type-fn alternate-alpha-fn :cache false) + s6 (mk-session [test-rule] :fact-type-fn alternate-alpha-fn :cache cache) + s7 (mk-session [test-rule test-rule] :fact-type-fn alternate-alpha-fn :cache cache) + s8 (mk-session [test-rule cold-query] :fact-type-fn alternate-alpha-fn :cache cache) + + ;; Find all distinct references, with distinctness determined by reference equality. + ;; If the reference to a session is identical to a previous session we infer that + ;; the session was the result of a cache hit; if the reference is not identical to + ;; a previous session it is the result of a cache miss. + distinct-sessions (reduce (fn [existing new] + (if-not (some (partial identical? new) + existing) + (conj existing new) + existing)) + [] + [s1 s2 s3 s4 s5 s6 s7 s8])] + (is (= distinct-sessions + [s1 s2 s5 s6 s8]))))) #_{:clj-kondo/ignore [:unresolved-symbol]} (deftest test-try-eval-failures-includes-compile-ctx @@ -1639,7 +1703,7 @@ [Hot (= ?t temperature)]]]] (insert-unconditional! (->First))) - q (dsl/parse-query [] [[First]]) + q (dsl/parse-query [] [[?result <- First]]) session->results (fn [session] (-> session (insert (->Cold 10) (->Hot 10)) @@ -1658,7 +1722,6 @@ :else 1)))) [])))) - (def some-rules [(assoc (dsl/parse-query [] [[Temperature (< temperature 40) (= ?t temperature) (= ?l location)]]) :name "cold") (assoc (dsl/parse-query [] [[Temperature (> temperature 80) (= ?t temperature) (= ?l location)]]) @@ -1689,7 +1752,7 @@ ;; Test bogus symbol (is (thrown? clojure.lang.ExceptionInfo - (mk-session 'clara.test-rules/bogus-symbol)))) + (mk-session 'clara.test-rules/bogus-symbol)))) (defprotocol Getter (getX [this]) @@ -1781,159 +1844,162 @@ (frequencies (query retract2 q)))))) (deftest test-rule-order-respected - (let [fire-order (atom []) - rule-A (dsl/parse-rule [[Cold]] - (swap! fire-order conj :A)) - rule-B (dsl/parse-rule [[Cold]] - (swap! fire-order conj :B))] - - (reset! fire-order []) - - (-> (mk-session [rule-A rule-B] :cache false) - (insert (->Cold 10)) - fire-rules) - (is (= @fire-order [:A :B]) - "Rule order in a seq of rule structures should be respected") - - (reset! fire-order []) + ;; This does not apply when doing parallel testing + (when-not tu/parallel-testing + (let [fire-order (atom []) + rule-A (dsl/parse-rule [[Cold]] + (swap! fire-order conj :A)) + rule-B (dsl/parse-rule [[Cold]] + (swap! fire-order conj :B))] - (-> (mk-session [rule-B rule-A] :cache false) - (insert (->Cold 10)) - fire-rules) - (is (= @fire-order [:B :A]) - "Validate that when we reverse the seq of rule structures the firing order is reversed.") + (reset! fire-order []) - (reset! fire-order []) - - (binding [order-rules/*rule-order-atom* fire-order] - (-> (mk-session [rule-A] 'clara.order-ruleset :cache false) + (-> (mk-session [rule-A rule-B] :cache false) (insert (->Cold 10)) fire-rules) - (is (= @fire-order [:A :C :D]) - "Rules should fire in the order they appear in a namespace. A rule that is before that namespace - in the rule sources should fire first.")) + (is (= @fire-order [:A :B]) + "Rule order in a seq of rule structures should be respected") - (reset! fire-order []) + (reset! fire-order []) - (binding [order-rules/*rule-order-atom* fire-order] - (-> (mk-session 'clara.order-ruleset [rule-A] :cache false) + (-> (mk-session [rule-B rule-A] :cache false) (insert (->Cold 10)) fire-rules) - (is (= @fire-order [:C :D :A]) - "Rules should fire in the order they appear in a namespace. A rule that is after that namespace - in the rule sources should fire later.")) + (is (= @fire-order [:B :A]) + "Validate that when we reverse the seq of rule structures the firing order is reversed.") + + (reset! fire-order []) - (reset! fire-order []) + (binding [order-rules/*rule-order-atom* fire-order] + (-> (mk-session [rule-A] 'clara.order-ruleset :cache false) + (insert (->Cold 10)) + fire-rules) + (is (= @fire-order [:A :C :D]) + "Rules should fire in the order they appear in a namespace. A rule that is before that namespace + in the rule sources should fire first.")) - (let [rule-C-line (-> #'order-rules/rule-C meta :line) - rule-D-line (-> #'order-rules/rule-D meta :line)] - (alter-meta! #'order-rules/rule-C (fn [m] (assoc m :line rule-D-line))) - (alter-meta! #'order-rules/rule-D (fn [m] (assoc m :line rule-C-line))) + (reset! fire-order []) (binding [order-rules/*rule-order-atom* fire-order] + (-> (mk-session 'clara.order-ruleset [rule-A] :cache false) + (insert (->Cold 10)) + fire-rules) + (is (= @fire-order [:C :D :A]) + "Rules should fire in the order they appear in a namespace. A rule that is after that namespace + in the rule sources should fire later.")) + + (reset! fire-order []) + + (let [rule-C-line (-> #'order-rules/rule-C meta :line) + rule-D-line (-> #'order-rules/rule-D meta :line)] + (alter-meta! #'order-rules/rule-C (fn [m] (assoc m :line rule-D-line))) + (alter-meta! #'order-rules/rule-D (fn [m] (assoc m :line rule-C-line))) + + (binding [order-rules/*rule-order-atom* fire-order] + (-> (mk-session 'clara.order-ruleset :cache false) + (insert (->Cold 10)) + fire-rules)) + + (is (= @fire-order [:D :C]) + "When we alter the metadata of the rules to reverse their line order their + firing order should also be reversed.") + + ;; Reset the line metadata on the rules to what it was previously. + (alter-meta! #'order-rules/rule-C (fn [m] (assoc m :line rule-C-line))) + (alter-meta! #'order-rules/rule-D (fn [m] (assoc m :line rule-D-line)))) + + (reset! fire-order []) + + (binding [order-rules/*rule-order-atom* fire-order + order-rules/*rule-seq-prior* [rule-A rule-B]] (-> (mk-session 'clara.order-ruleset :cache false) (insert (->Cold 10)) - fire-rules)) + fire-rules) + (is (= @fire-order [:A :B :C :D]) + "When a :production-seq occurs before defrules, the rules in the :production-seq + should fire before those rules and in the order they are in in the :production-seq.")) - (is (= @fire-order [:D :C]) - "When we alter the metadata of the rules to reverse their line order their - firing order should also be reversed.") + (reset! fire-order []) - ;; Reset the line metadata on the rules to what it was previously. - (alter-meta! #'order-rules/rule-C (fn [m] (assoc m :line rule-C-line))) - (alter-meta! #'order-rules/rule-D (fn [m] (assoc m :line rule-D-line)))) + (binding [order-rules/*rule-order-atom* fire-order + order-rules/*rule-seq-after* [rule-A rule-B]] + (-> (mk-session 'clara.order-ruleset :cache false) + (insert (->Cold 10)) + fire-rules) + (is (= @fire-order [:C :D :A :B]) + "When a :production-seq occurs after defrules, the rules in the :production-seq + should fire after those rules and in the order they are in in the :production-seq.")) - (reset! fire-order []) + (reset! fire-order []) - (binding [order-rules/*rule-order-atom* fire-order - order-rules/*rule-seq-prior* [rule-A rule-B]] - (-> (mk-session 'clara.order-ruleset :cache false) - (insert (->Cold 10)) - fire-rules) - (is (= @fire-order [:A :B :C :D]) - "When a :production-seq occurs before defrules, the rules in the :production-seq - should fire before those rules and in the order they are in in the :production-seq.")) + (binding [order-rules/*rule-order-atom* fire-order + order-rules/*rule-seq-after* [rule-B rule-A]] + (-> (mk-session 'clara.order-ruleset :cache false) + (insert (->Cold 10)) + fire-rules) + (is (= @fire-order [:C :D :B :A]) + "Validate that when the order of rules in the :production-seq is reversed those rules + fire in the reversed order")) - (reset! fire-order []) + (reset! fire-order []) - (binding [order-rules/*rule-order-atom* fire-order - order-rules/*rule-seq-after* [rule-A rule-B]] - (-> (mk-session 'clara.order-ruleset :cache false) + (-> (mk-session [rule-A (assoc-in rule-B [:props :salience] 1)] :cache false) (insert (->Cold 10)) fire-rules) - (is (= @fire-order [:C :D :A :B]) - "When a :production-seq occurs after defrules, the rules in the :production-seq - should fire after those rules and in the order they are in in the :production-seq.")) + (is (= @fire-order [:B :A]) + "Validate that when explicit salience is present it overrides rule order.") - (reset! fire-order []) + (reset! fire-order []) - (binding [order-rules/*rule-order-atom* fire-order - order-rules/*rule-seq-after* [rule-B rule-A]] - (-> (mk-session 'clara.order-ruleset :cache false) + (-> (mk-session [rule-A rule-B rule-A] :cache false) (insert (->Cold 10)) fire-rules) - (is (= @fire-order [:C :D :B :A]) - "Validate that when the order of rules in the :production-seq is reversed those rules - fire in the reversed order")) - - (reset! fire-order []) - - (-> (mk-session [rule-A (assoc-in rule-B [:props :salience] 1)] :cache false) - (insert (->Cold 10)) - fire-rules) - (is (= @fire-order [:B :A]) - "Validate that when explicit salience is present it overrides rule order.") - - (reset! fire-order []) + (is (= @fire-order [:A :B]) + "Validate that the first occurence of a rule is used for rule ordering when it occurs multiple times.") - (-> (mk-session [rule-A rule-B rule-A] :cache false) - (insert (->Cold 10)) - fire-rules) - (is (= @fire-order [:A :B]) - "Validate that the first occurence of a rule is used for rule ordering when it occurs multiple times.") - - (reset! fire-order []))) + (reset! fire-order [])))) (deftest test-rule-order-respected-by-batched-inserts - (let [qholder (atom []) - - r1 (dsl/parse-rule [[Temperature (= ?t temperature)]] - (insert! (->Cold ?t))) - r2 (dsl/parse-rule [[Temperature (= ?t temperature)]] - (insert! (->Hot ?t))) - - ;; Make two "alpha roots" that the 2 rules above insertions will need to propagate to. - q1 (dsl/parse-query [] [[?c <- Cold (swap! qholder conj :cold)]]) - q2 (dsl/parse-query [] [[?h <- Hot (swap! qholder conj :hot)]]) - - order1 (mk-session [r1 r2 q1 q2] :cache false) - order2 (mk-session [r2 r1 q1 q2] :cache false) - - run-session (fn [s] - (let [s (-> s - (insert (->Temperature 10 "MCI")) - fire-rules)] - [(-> s (query q1) frequencies) - (-> s (query q2) frequencies)])) - - [res11 res12] (run-session order1) - holder1 @qholder - _ (reset! qholder []) - - [res21 res22] (run-session order2) - holder2 @qholder - _ (reset! qholder [])] - - ;; Sanity check that the query matches what is expected. - (is (= (frequencies [{:?c (->Cold 10)}]) - res11 - res21)) - (is (= (frequencies [{:?h (->Hot 10)}]) - res12 - res22)) - - (is (= [:cold :hot] holder1)) - (is (= [:hot :cold] holder2)))) + (when-not tu/parallel-testing + (let [qholder (atom []) + + r1 (dsl/parse-rule [[Temperature (= ?t temperature)]] + (insert! (->Cold ?t))) + r2 (dsl/parse-rule [[Temperature (= ?t temperature)]] + (insert! (->Hot ?t))) + + ;; Make two "alpha roots" that the 2 rules above insertions will need to propagate to. + q1 (dsl/parse-query [] [[?c <- Cold (swap! qholder conj :cold)]]) + q2 (dsl/parse-query [] [[?h <- Hot (swap! qholder conj :hot)]]) + + order1 (mk-session [r1 r2 q1 q2] :cache false) + order2 (mk-session [r2 r1 q1 q2] :cache false) + + run-session (fn [s] + (let [s (-> s + (insert (->Temperature 10 "MCI")) + fire-rules)] + [(-> s (query q1) frequencies) + (-> s (query q2) frequencies)])) + + [res11 res12] (run-session order1) + holder1 @qholder + _ (reset! qholder []) + + [res21 res22] (run-session order2) + holder2 @qholder + _ (reset! qholder [])] + + ;; Sanity check that the query matches what is expected. + (is (= (frequencies [{:?c (->Cold 10)}]) + res11 + res21)) + (is (= (frequencies [{:?h (->Hot 10)}]) + res12 + res22)) + + (is (= [:cold :hot] holder1)) + (is (= [:hot :cold] holder2))))) ;; TODO: Move this to test-dsl once a strategy for replicating assert-ex-data is determined and implemented. #_{:clj-kondo/ignore [:unresolved-symbol]} @@ -1941,7 +2007,7 @@ (let [q (dsl/parse-query [] [[Temperature (= ?t (+ 5 temperature)) (< ?t 10)]]) ;; Test that a value must be bound before use. - invalid (dsl/parse-query [] [[Temperature (< ?t 10) (= ?t (+ 5 temperature))]] ) + invalid (dsl/parse-query [] [[Temperature (< ?t 10) (= ?t (+ 5 temperature))]]) s (mk-session [q] :cache false)] @@ -1954,10 +2020,10 @@ ;; Item that does satisfy second criterion should match. (is (= [{:?t 5}] - (-> s - (insert (->Temperature 0 "MCI")) - (fire-rules) - (query q)))) + (-> s + (insert (->Temperature 0 "MCI")) + (fire-rules) + (query q)))) ;; The variable used out of order should be marked as unbound. (assert-ex-data {:variables #{'?t}} @@ -2016,13 +2082,13 @@ (let [accum-state (atom []) stateful-accum (acc/accum - {:initial-value [] - :reduce-fn conj - :retract-fn (fn [items retracted] (remove #{retracted} items)) - :convert-return-fn (fn [items] - (do - (swap! accum-state conj items) - items))}) + {:initial-value [] + :reduce-fn conj + :retract-fn (fn [items retracted] (remove #{retracted} items)) + :convert-return-fn (fn [items] + (do + (swap! accum-state conj items) + items))}) common-ancestor-rule (dsl/parse-rule [[?lists <- stateful-accum :from [List]]] ;; don't care about whats inserted @@ -2032,8 +2098,8 @@ linked-list (LinkedList.) ses (-> (mk-session [common-ancestor-rule]) - (insert-all [array-list linked-list]) - (fire-rules))] + (insert-all [array-list linked-list]) + (fire-rules))] (is (not-any? #(= 1 (count %)) @accum-state) "Facts with common ancestors should be batched together, expected either the initial accumulator value or a vector containing both lists but never a vector containing one list."))) @@ -2419,12 +2485,13 @@ (deftest test-duplicate-name (assert-ex-data {:names #{::rules-data/is-cold-and-windy-data}} (com/mk-session* - (set (com/add-production-load-order (conj (rules-data/weather-rules-with-keyword-names) - {:doc "An extra rule to test for duplicate names." - :name :clara.rules.test-rules-data/is-cold-and-windy-data - :lhs [] - :rhs '(println "I have no meaning outside of this test")}))) {}))) + (set (com/add-production-load-order (conj (rules-data/weather-rules-with-keyword-names) + {:doc "An extra rule to test for duplicate names." + :name :clara.rules.test-rules-data/is-cold-and-windy-data + :lhs [] + :rhs '(println "I have no meaning outside of this test")}))) {}))) +#_{:clj-kondo/ignore [:unresolved-symbol]} (deftest test-negation-multiple-children-exception (let [not-rule (dsl/parse-rule [[:not [Hot (= ?t temperature)] diff --git a/src/test/common/clara/test_rules_require.cljc b/src/test/clojure/clara/test_rules_require.clj similarity index 82% rename from src/test/common/clara/test_rules_require.cljc rename to src/test/clojure/clara/test_rules_require.clj index f98e60d8..22f588f1 100644 --- a/src/test/common/clara/test_rules_require.cljc +++ b/src/test/clojure/clara/test_rules_require.clj @@ -2,10 +2,8 @@ (:require [clara.tools.testing-utils :as tu] [clara.rule-defs :as rd] [clara.rules.testfacts :as facts] - #?(:clj [clojure.test :refer [is deftest run-tests testing use-fixtures]]) - #?(:cljs [cljs.test :refer-macros [is deftest run-tests testing use-fixtures]]) - #?(:clj [clara.rules :refer [insert fire-rules query defsession]]) - #?(:cljs [clara.rules :refer [insert fire-rules query] :refer-macros [defsession]]))) + [clojure.test :refer [is deftest run-tests testing use-fixtures]] + [clara.rules :refer [insert fire-rules query defsession]])) ;; Tests the case where rules/facts are required from a different namespace where the session is defined, ;; without an explicit :refer. @@ -51,5 +49,5 @@ (is (= #{{:?fact (facts/->ColdAndWindy 15 45)}} (set - (query session rd/find-cold-and-windy)))))) + (query session rd/find-cold-and-windy)))))) diff --git a/src/test/clojure/clara/test_setup.clj b/src/test/clojure/clara/test_setup.clj new file mode 100644 index 00000000..498cb939 --- /dev/null +++ b/src/test/clojure/clara/test_setup.clj @@ -0,0 +1,18 @@ +(ns clara.test-setup + "Things we need to do in order to run tests with a smile" + (:require [kaocha.hierarchy :as hierarchy] + [pjstadig.humane-test-output :as hto])) + +(hierarchy/derive! ::ignore :kaocha/known-key) + +(hto/activate!) + +(defn defuse-zero-assertions + "Don't fail the test suite if we hide an `is` within a `doseq`. + + See also https://cljdoc.org/d/lambdaisland/kaocha/1.80.1274/doc/-clojure-test-assertion-extensions#detecting-missing-assertions" + [event] + (if (= (:type event) :kaocha.type.var/zero-assertions) + (assoc event :type ::ignore) + event)) + diff --git a/src/test/common/clara/test_simple_rules.cljc b/src/test/clojure/clara/test_simple_rules.clj similarity index 70% rename from src/test/common/clara/test_simple_rules.cljc rename to src/test/clojure/clara/test_simple_rules.clj index f72d0d5e..6560c027 100644 --- a/src/test/common/clara/test_simple_rules.cljc +++ b/src/test/clojure/clara/test_simple_rules.clj @@ -3,52 +3,24 @@ ;; test namespaces due to this simplicity. This functionality is transitively ;; tested by numerous other tests, but there is some value in having direct tests ;; in case the complexity of those tests obscured a simpler issue. -#?(:clj - (ns clara.test-simple-rules - (:require [clara.tools.testing-utils :refer [def-rules-test - side-effect-holder] :as tu] - [clara.rules :refer [fire-rules - insert - insert-all - insert-all! - insert! - retract - query]] - - [clara.rules.testfacts :refer [->Temperature ->Cold ->WindSpeed - ->ColdAndWindy ->LousyWeather]] - [clojure.test :refer [is deftest run-tests testing use-fixtures]] - [clara.rules.accumulators] - [schema.test :as st]) - (:import [clara.rules.testfacts - Temperature - Cold - WindSpeed - ColdAndWindy - LousyWeather])) - - :cljs - (ns clara.test-simple-rules - (:require [clara.rules :refer [fire-rules - insert - insert! - insert-all - insert-all! - retract - query]] - [clara.rules.testfacts :refer [->Temperature Temperature - ->Cold Cold - ->WindSpeed WindSpeed - ->ColdAndWindy ColdAndWindy - ->LousyWeather LousyWeather]] - [clara.rules.accumulators] - [cljs.test] - [schema.test :as st] - [clara.tools.testing-utils :refer [side-effect-holder] :as tu]) - (:require-macros [clara.tools.testing-utils :refer [def-rules-test]] - [cljs.test :refer [is deftest run-tests testing use-fixtures]]))) - -(use-fixtures :once st/validate-schemas #?(:clj tu/opts-fixture)) +(ns clara.test-simple-rules + (:require + [clara.rules :refer [fire-rules insert query retract insert! retract! insert-all!]] + [clara.rules.accumulators] + [clara.rules.testfacts :refer [->Temperature ->WindSpeed ->Cold ->LousyWeather]] + [clara.tools.testing-utils :refer [def-rules-test side-effect-holder] :as tu] + [clojure.test :refer [is use-fixtures]] + [schema.test :as st]) + (:import + [java.lang IllegalArgumentException] + [clara.rules.testfacts + Temperature + WindSpeed + Cold + ColdAndWindy + LousyWeather])) + +(use-fixtures :once st/validate-schemas tu/opts-fixture) (use-fixtures :each tu/side-effect-holder-fixture) (defn- has-fact? [token fact] @@ -191,7 +163,7 @@ (insert (->Temperature -10 "MCI")) fire-rules)] - (is (has-fact? (:cold @side-effect-holder) (->Temperature -10 "MCI") )) + (is (has-fact? (:cold @side-effect-holder) (->Temperature -10 "MCI"))) (is (has-fact? (:subzero @side-effect-holder) (->Temperature -10 "MCI"))))) @@ -213,14 +185,11 @@ (is (= #{{:?t 10}} (set (query session temp-query :?t 10)))) - (is (thrown-with-msg? #?(:clj IllegalArgumentException :cljs js/Error) - expected-msg + (is (thrown-with-msg? IllegalArgumentException expected-msg (query session temp-query :?another-param 42))) - (is (thrown-with-msg? #?(:clj IllegalArgumentException :cljs js/Error) - expected-msg + (is (thrown-with-msg? IllegalArgumentException expected-msg (query session temp-query))) - (is (thrown-with-msg? #?(:clj IllegalArgumentException :cljs js/Error) - expected-msg + (is (thrown-with-msg? IllegalArgumentException expected-msg (query session temp-query :?t 42 :?another-param 42))))) diff --git a/src/test/common/clara/test_testing_utils.cljc b/src/test/clojure/clara/test_testing_utils.clj similarity index 68% rename from src/test/common/clara/test_testing_utils.cljc rename to src/test/clojure/clara/test_testing_utils.clj index 00179cea..98126676 100644 --- a/src/test/common/clara/test_testing_utils.cljc +++ b/src/test/clojure/clara/test_testing_utils.clj @@ -1,24 +1,13 @@ -#?(:clj - (ns clara.test-testing-utils - (:require [clara.tools.testing-utils :refer [def-rules-test - run-performance-test]] - [clara.rules :as r] - - [clara.rules.testfacts :refer [->Temperature ->Cold]] - [clojure.test :refer [is deftest run-tests] :as t]) - (:import [clara.rules.testfacts - Temperature - Cold])) - - :cljs - (ns clara.test-testing-utils - (:require [clara.rules :as r] - [clara.rules.testfacts :refer [->Temperature Temperature - ->Cold Cold]] - [cljs.test :as t] - [clara.tools.testing-utils :refer [run-performance-test]]) - (:require-macros [clara.tools.testing-utils :refer [def-rules-test]] - [cljs.test :refer (is deftest run-tests)]))) +(ns clara.test-testing-utils + (:require [clara.tools.testing-utils :refer [def-rules-test + run-performance-test]] + [clara.rules :as r] + + [clara.rules.testfacts :refer [->Temperature ->Cold]] + [clojure.test :refer [is deftest run-tests] :as t]) + (:import [clara.rules.testfacts + Temperature + Cold])) (def test-ran-atom (atom false)) diff --git a/src/test/common/clara/test_truth_maintenance.cljc b/src/test/clojure/clara/test_truth_maintenance.clj similarity index 83% rename from src/test/common/clara/test_truth_maintenance.cljc rename to src/test/clojure/clara/test_truth_maintenance.clj index 41dfe6f2..d2a1d00c 100644 --- a/src/test/common/clara/test_truth_maintenance.cljc +++ b/src/test/clojure/clara/test_truth_maintenance.clj @@ -1,58 +1,32 @@ -#?(:clj - (ns clara.test-truth-maintenance - (:require [clara.tools.testing-utils :refer [def-rules-test] :as tu] - [clara.rules :refer [fire-rules - insert - insert-all - insert! - insert-unconditional! - insert-all-unconditional! - retract - retract! - query]] - [clara.rules.testfacts :refer [->Temperature ->Cold ->WindSpeed - ->TemperatureHistory ->LousyWeather - ->ColdAndWindy ->First ->Second ->Third]] - [clojure.test :refer [is deftest run-tests testing use-fixtures]] - [clara.rules.accumulators :as acc] - [schema.test :as st]) - (:import [clara.rules.testfacts - Temperature - TemperatureHistory - Cold - ColdAndWindy - WindSpeed - LousyWeather - First - Second - Third])) - - :cljs - (ns clara.test-truth-maintenance - (:require [clara.rules :refer [fire-rules - insert - insert! - insert-unconditional! - insert-all-unconditional! - insert-all - retract - retract! - query]] - [clara.rules.accumulators :as acc] - [clara.rules.testfacts :refer [->Temperature Temperature - ->TemperatureHistory TemperatureHistory - ->Cold Cold - ->ColdAndWindy ColdAndWindy - ->WindSpeed WindSpeed - ->LousyWeather LousyWeather - ->First First - ->Second Second - ->Third Third]] - [schema.test :as st]) - (:require-macros [clara.tools.testing-utils :refer [def-rules-test]] - [cljs.test :refer [is deftest run-tests testing use-fixtures]]))) - -(use-fixtures :once st/validate-schemas #?(:clj tu/opts-fixture)) +(ns clara.test-truth-maintenance + (:require [clara.tools.testing-utils :refer [def-rules-test] :as tu] + [clara.rules :refer [fire-rules + insert + insert-all + insert! + insert-unconditional! + insert-all-unconditional! + retract + retract! + query]] + [clara.rules.testfacts :refer [->Temperature ->Cold ->WindSpeed + ->TemperatureHistory ->LousyWeather + ->ColdAndWindy ->First ->Second ->Third]] + [clojure.test :refer [is deftest run-tests testing use-fixtures]] + [clara.rules.accumulators :as acc] + [schema.test :as st]) + (:import [clara.rules.testfacts + Temperature + TemperatureHistory + Cold + ColdAndWindy + WindSpeed + LousyWeather + First + Second + Third])) + +(use-fixtures :once st/validate-schemas tu/opts-fixture) ;; Any tests using this atom are expected to reset its value during initialization ;; of the test rather than requiring tests to reset after completing. @@ -308,12 +282,12 @@ (is (= [{:?t (->TemperatureHistory #{(->Temperature 20 "MCI") (->Temperature 25 "MCI") (->Temperature 30 "SFO")})}] - + (-> session1 fire-rules (query temp-query)) (-> session2 fire-rules (query temp-query)) (-> session3 fire-rules (query temp-query)) (-> session4 fire-rules (query temp-query)) - + (-> session5 fire-rules (query temp-query)) (-> session6 fire-rules (query temp-query)) (-> session7 fire-rules (query temp-query)) @@ -421,10 +395,10 @@ {:rules [r1 [[[First]] ;; As of writing the engine rearranges ;; this so that the retraction comes last. - (do (retract! (->Cold 5)) - (insert! (->Third)))] + (do (retract! (->Cold 5)) + (insert! (->Third)))] r2 [[[Second] - [:not [Third]]] + [:not [Third]]] (insert! (->Cold 5))]] :queries [q [[] [[Cold (= ?t temperature)]]]] @@ -432,13 +406,13 @@ :sessions [base-session [r1 r2 q] {}]} (is (= (-> base-session - (insert (->Second)) - (fire-rules) - (insert (->First)) - (fire-rules) - (query q)) - []) - "A retraction that becomes redundant after reordering of insertions + (insert (->Second)) + (fire-rules) + (insert (->First)) + (fire-rules) + (query q)) + []) + "A retraction that becomes redundant after reordering of insertions and retractions due to batching should not cause failure.")) (def-rules-test test-remove-pending-activation-with-equal-previous-insertion diff --git a/src/test/common/clara/tools/test_fact_graph.cljc b/src/test/clojure/clara/tools/test_fact_graph.clj similarity index 95% rename from src/test/common/clara/tools/test_fact_graph.cljc rename to src/test/clojure/clara/tools/test_fact_graph.clj index b3eeeebc..b6cb979b 100644 --- a/src/test/common/clara/tools/test_fact_graph.cljc +++ b/src/test/clojure/clara/tools/test_fact_graph.clj @@ -4,12 +4,9 @@ [clara.rules :as cr] [clara.rules.accumulators :as acc] [schema.test :as st] - #?(:clj [clojure.test :refer [is deftest run-tests testing use-fixtures]] - :cljs [cljs.test :refer-macros [is deftest run-tests testing use-fixtures]]) - #?(:clj [clara.rules.testfacts :as tf] - :cljs [clara.rules.testfacts :refer [Cold WindSpeed ColdAndWindy] :as tf])) - #?(:clj - (:import [clara.rules.testfacts Cold WindSpeed ColdAndWindy]))) + [clojure.test :refer [is deftest run-tests testing use-fixtures]] + [clara.rules.testfacts :as tf]) + (:import [clara.rules.testfacts Cold WindSpeed ColdAndWindy])) (use-fixtures :once st/validate-schemas) diff --git a/src/test/common/clara/tools/test_inspect.cljc b/src/test/clojure/clara/tools/test_inspect.clj similarity index 90% rename from src/test/common/clara/tools/test_inspect.cljc rename to src/test/clojure/clara/tools/test_inspect.clj index de89e08c..e245c7df 100644 --- a/src/test/common/clara/tools/test_inspect.cljc +++ b/src/test/clojure/clara/tools/test_inspect.clj @@ -9,24 +9,13 @@ [clara.rules.accumulators :as acc] [schema.test :as st] [clojure.walk :as w] - #?(:cljs [goog.string :as gstr]) - #?(:cljs [cljs.core :refer [ExceptionInfo]]) - #?(:clj [clojure.test :refer [is deftest run-tests testing use-fixtures]] - :cljs [cljs.test :refer-macros [is deftest run-tests testing use-fixtures]]) - #?(:clj [clara.rules.testfacts :refer :all] - :cljs [clara.rules.testfacts :refer [Temperature TemperatureHistory - WindSpeed Cold Hot ColdAndWindy LousyWeather - First Second Third Fourth - map->Cold map->Hot - ->Temperature ->TemperatureHistory - ->WindSpeed ->Cold ->Hot ->ColdAndWindy ->LousyWeather - ->First ->Second ->Third ->Fourth]])) - #?(:clj - (:import [clara.rules.testfacts Temperature TemperatureHistory - WindSpeed Cold Hot ColdAndWindy LousyWeather - First Second Third Fourth] - [clojure.lang - ExceptionInfo]))) + [clojure.test :refer [is deftest run-tests testing use-fixtures]] + [clara.rules.testfacts :refer :all]) + (:import [clara.rules.testfacts Temperature TemperatureHistory + WindSpeed Cold Hot ColdAndWindy LousyWeather + First Second Third Fourth] + [clojure.lang + ExceptionInfo])) (use-fixtures :once schema.test/validate-schemas) @@ -191,8 +180,7 @@ constraints (map (comp :constraints :condition) matches) term (flatten constraints)] (is (not (and (symbol? term) - #?(:clj (.startsWith (name term) "?__gen")) - #?(:cljs (gstr/startsWith (name term) "?__gen")))))))) + (.startsWith (name term) "?__gen"))))))) (defn session->accumulated-facts-map "Given a session, return a map of logically inserted facts to any accumulated-over facts @@ -225,21 +213,21 @@ matches))] (as-> session x - (inspect x) - (:fact->explanations x) - (into {} - (map (fn [[k v]] - [k (->> v - fail-on-multiple-insertions - first - :explanation - :matches - (filter (comp :accumulator :condition)) - fail-on-multiple-accum-conditions - first - :facts-accumulated - frequencies)])) - x)))) + (inspect x) + (:fact->explanations x) + (into {} + (map (fn [[k v]] + [k (->> v + fail-on-multiple-insertions + first + :explanation + :matches + (filter (comp :accumulator :condition)) + fail-on-multiple-accum-conditions + first + :facts-accumulated + frequencies)])) + x)))) (tu/def-rules-test test-get-matching-accum-facts-with-no-previous-conditions-and-new-binding {:rules [min-freezing-at-loc-rule [[[?min <- (acc/min :temperature) from [Temperature (< temperature 0) (= ?loc location)]]] @@ -332,7 +320,7 @@ empty-with-temps-complex-join-unused-previous-binding [windspeed-with-temps-complex-join-unused-previous-binding temp-history-query] {:cache false} empty-with-temps-complex-join-subsequent-binding [windspeed-with-temps-complex-join-subsequent-binding - temp-history-query] {:cache false}]} + temp-history-query] {:cache false}]} (doseq [[empty-session join-type unused-previous-binding @@ -435,9 +423,9 @@ [condition-matches] (let [rename-fn (fn [form] (if - (and - (map? form) - (contains? form :original-constraints)) + (and + (map? form) + (contains? form :original-constraints)) (-> form (dissoc :original-constraints) (assoc :constraints (:original-constraints form))) @@ -530,18 +518,18 @@ (query complex-successful-join cold-windy-query) [{:?t 0 :?w 50}])) - (is (= (get-condition-match simple-successful-join #?(:clj Temperature :cljs `Temperature)) - (get-condition-match complex-successful-join #?(:clj Temperature :cljs `Temperature)) + (is (= (get-condition-match simple-successful-join Temperature) + (get-condition-match complex-successful-join Temperature) [(->Temperature 0 "MCI")])) - (is (= (get-condition-match simple-failed-join #?(:clj Temperature :cljs `Temperature)) - (get-condition-match complex-failed-join #?(:clj Temperature :cljs `Temperature)) + (is (= (get-condition-match simple-failed-join Temperature) + (get-condition-match complex-failed-join Temperature) [(->Temperature 0 "ORD")])) - (is (= (get-condition-match simple-successful-join #?(:clj WindSpeed :cljs `WindSpeed)) - (get-condition-match complex-successful-join #?(:clj WindSpeed :cljs `WindSpeed)) - (get-condition-match simple-failed-join #?(:clj WindSpeed :cljs `WindSpeed)) - (get-condition-match complex-failed-join #?(:clj WindSpeed :cljs `WindSpeed)) + (is (= (get-condition-match simple-successful-join WindSpeed) + (get-condition-match complex-successful-join WindSpeed) + (get-condition-match simple-failed-join WindSpeed) + (get-condition-match complex-failed-join WindSpeed) [(->WindSpeed 50 "MCI")])))) (tu/def-rules-test test-explain-activations-does-not-crash @@ -554,7 +542,7 @@ (is (with-out-str (explain-activations session))))) (tu/def-rules-test test-unconditional-rule-matches - + {:rules [cold-rule [[[Cold]] (insert-unconditional! (->LousyWeather))]] :sessions [base-session [cold-rule] {}]} @@ -598,14 +586,10 @@ prod-name-using-sym (first (node-fn-name->production-name base-session 'clara.tools.test-inspect/AN_1_AE)) - prod-name-using-fn #?(:clj (first (node-fn-name->production-name base-session + prod-name-using-fn (first (node-fn-name->production-name base-session ;; it doesn't really matter what the fn does, just that it is named ;; correctly - (fn AN-1-AE [] 42))) - ;; in later versions of clojurescript anonymous functions no longer have mapped names - ;; when compiled in an optimized manner - :cljs "cold-rule") - ] + (fn AN-1-AE [] 42)))] (is (= prod-name-using-str "cold-rule")) (is (= prod-name-using-sym "cold-rule")) (is (= prod-name-using-fn "cold-rule")))) @@ -639,4 +623,4 @@ (catch ExceptionInfo exc (is (= (ex-data exc) {:node-id "9001" - :simple-name "AN-9001-AE"})))))) \ No newline at end of file + :simple-name "AN-9001-AE"})))))) diff --git a/src/test/common/clara/tools/test_tracing.cljc b/src/test/clojure/clara/tools/test_tracing.clj similarity index 70% rename from src/test/common/clara/tools/test_tracing.cljc rename to src/test/clojure/clara/tools/test_tracing.clj index d560b8f9..56862983 100644 --- a/src/test/common/clara/tools/test_tracing.cljc +++ b/src/test/clojure/clara/tools/test_tracing.clj @@ -1,39 +1,18 @@ -#?(:clj - (ns clara.tools.test-tracing - (:require [clara.tools.testing-utils :refer [def-rules-test] :as tu] - [clara.rules :refer [fire-rules - insert - insert-all - insert! - retract - retract! - query]] - [clara.tools.tracing :as t] - [clara.rules.accumulators :as acc] - [clara.rules.testfacts :refer :all] - [clojure.test :refer :all]) - (:import [clara.rules.testfacts Temperature WindSpeed Cold Hot TemperatureHistory - ColdAndWindy LousyWeather First Second Third Fourth])) - - :cljs - (ns clara.tools.test-tracing - (:require [clara.rules :refer [fire-rules - insert - insert! - retract! - insert-all - retract - query]] - [clara.tools.tracing :as t] - [clara.rules.accumulators :as acc] - [clara.rules.testfacts :refer [->Temperature Temperature - ->TemperatureHistory TemperatureHistory - ->Hot Hot - ->Cold Cold - ->ColdAndWindy ColdAndWindy - ->WindSpeed WindSpeed]]) - (:require-macros [clara.tools.testing-utils :refer [def-rules-test]] - [cljs.test :refer [is deftest run-tests testing use-fixtures]]))) +(ns clara.tools.test-tracing + (:require [clara.tools.testing-utils :refer [def-rules-test] :as tu] + [clara.rules :refer [fire-rules + insert + insert-all + insert! + retract + retract! + query]] + [clara.tools.tracing :as t] + [clara.rules.accumulators :as acc] + [clara.rules.testfacts :refer :all] + [clojure.test :refer :all]) + (:import [clara.rules.testfacts Temperature WindSpeed Cold Hot TemperatureHistory + ColdAndWindy LousyWeather First Second Third Fourth])) (def-rules-test test-tracing-toggle {:rules [cold-rule [[[Temperature (< temperature 20)]] @@ -85,7 +64,7 @@ :alpha-retract :right-retract :left-retract]) "Validate that a retract! call in the RHS side of a rule appears in the trace before the :right-retract"))) - + (def-rules-test test-accumulate-trace {:queries [coldest-query [[] [[?t <- (acc/min :temperature :returns-fact true) from [Temperature]]]]] @@ -125,14 +104,14 @@ (insert! (->Cold ?temperature))]] :sessions [empty-session [cold-rule] {}]} - (let [session (-> empty-session - (t/with-tracing) - (insert (->Temperature 10 "MCI")) - (fire-rules))] + (let [session (-> empty-session + (t/with-tracing) + (insert (->Temperature 10 "MCI")) + (fire-rules))] ;; Ensure expected events occur in order. - (is (= [:add-facts :alpha-activate :right-activate :left-activate - :add-activations :fire-activation :add-facts-logical :activation-group-transition] + (is (= [:add-facts :alpha-activate :right-activate :left-activate + :add-activations :fire-activation :add-facts-logical :activation-group-transition] (map :type (t/get-trace session)))))) (def-rules-test test-insert-and-retract-trace @@ -140,7 +119,7 @@ (insert! (->Cold ?temperature))]] :sessions [empty-session [cold-rule] {:cache false}]} - (let [session (-> empty-session + (let [session (-> empty-session (t/with-tracing) (insert (->Temperature 10 "MCI") (->Temperature 20 "MCI")) @@ -148,17 +127,17 @@ (retract (->Temperature 10 "MCI")) (fire-rules)) - session-trace (t/get-trace session)] + session-trace (t/get-trace session)] ;; Ensure expected events occur in order. - (is (= [:add-facts :alpha-activate :right-activate :left-activate :add-activations :fire-activation - :add-facts-logical :activation-group-transition :retract-facts :alpha-retract :right-retract - :left-retract :remove-activations :retract-facts-logical] - (map :type session-trace))) + (is (= [:add-facts :alpha-activate :right-activate :left-activate :add-activations :fire-activation + :add-facts-logical :activation-group-transition :retract-facts :alpha-retract :right-retract + :left-retract :remove-activations :retract-facts-logical :activation-group-transition] + (map :type session-trace))) ;; Ensure only the expected fact was indicated as retracted. - (let [retraction (first (filter #(= :retract-facts-logical (:type %)) session-trace))] - (is (= [(->Cold 10)] (:facts retraction)))))) + (let [retraction (first (filter #(= :retract-facts-logical (:type %)) session-trace))] + (is (= [(->Cold 10)] (:facts retraction)))))) (def-rules-test test-ranked-productions {:rules [temperature-rule [[[Temperature (= ?temperature temperature) (< temperature 20)]] diff --git a/src/test/clojurescript/clara/test.cljs b/src/test/clojurescript/clara/test.cljs deleted file mode 100644 index 4f54f66d..00000000 --- a/src/test/clojurescript/clara/test.cljs +++ /dev/null @@ -1,66 +0,0 @@ -(ns clara.test - (:require-macros [cljs.test :as test]) - (:require [clara.test-rules] - [clara.test-rules-require] - [cljs.test] - [clara.test-salience] - [clara.test-complex-negation] - [clara.test-common] - [clara.test-testing-utils] - [clara.test-accumulators] - [clara.test-exists] - [clara.tools.test-tracing] - [clara.tools.test-fact-graph] - [clara.tools.test-inspect] - [clara.test-truth-maintenance] - [clara.test-dsl] - [clara.test-accumulation] - [clara.test-memory] - [clara.test-simple-rules] - [clara.test-rhs-retract] - [clara.test-bindings] - [clara.test-clear-ns-productions] - [clara.test-negation] - [clara.performance.test-rule-execution] - [clara.test-node-sharing] - [clara.test-queries])) - -(enable-console-print!) - -(def ^:dynamic *successful?* nil) - -(defmethod cljs.test/report [:cljs.test/default :end-run-tests] [m] - (if (cljs.test/successful? m) - (do - (println "Success!") - (reset! *successful?* true)) - (do - (println "FAIL") - (reset! *successful?* false)))) - -(defn ^:export run [] - (binding [*successful?* (atom nil)] - (test/run-tests 'clara.test-rules - 'clara.test-rules-require - 'clara.test-common - 'clara.test-salience - 'clara.test-testing-utils - 'clara.test-complex-negation - 'clara.test-accumulators - 'clara.test-exists - 'clara.tools.test-tracing - 'clara.tools.test-fact-graph - 'clara.tools.test-inspect - 'clara.test-truth-maintenance - 'clara.test-dsl - 'clara.test-accumulation - 'clara.test-memory - 'clara.test-simple-rules - 'clara.test-rhs-retract - 'clara.test-bindings - 'clara.test-clear-ns-productions - 'clara.test-negation - 'clara.performance.test-rule-execution - 'clara.test-node-sharing - 'clara.test-queries) - @*successful?*)) diff --git a/src/test/clojurescript/clara/test_complex_negation.cljs b/src/test/clojurescript/clara/test_complex_negation.cljs deleted file mode 100644 index 6eec2397..00000000 --- a/src/test/clojurescript/clara/test_complex_negation.cljs +++ /dev/null @@ -1,80 +0,0 @@ -(ns clara.test-complex-negation - "Tests that validate that we wrap the fact-type-fn and ancestors-fn so that Clara's internal - facts, for example NegationResult facts (added to fix issue 149) are not provided to user-provided - custom fact-type-fn or ancestors-fn functions." - (:require [clara.rules - :refer-macros [defquery - defsession] - :refer [query - insert - fire-rules]] - [clara.rules.testfacts :refer [Temperature ->Temperature - WindSpeed ->WindSpeed - Cold ->Cold]] - [cljs.test :as t] - [cljs.test :refer-macros [run-tests - deftest - is] - :include-macros true])) - -(defquery negation-inside-negation-query - [] - [:windspeed (= ?l (:location this))] - [:not [:and - [?t <- :temperature (= ?l (:location this))] - [:not [:cold (= (:temperature this) (:temperature ?t))]]]]) - -;; Use ancestors of the fact types to ensure that the custom ancestors-fn -;; is used and that its arguments are the types from the custom fact-type-fn -(defquery negation-inside-negation-ancestors-query - [] - [:windspeed-ancestor (= ?l (:location this))] - [:not [:and - [?t <- :temperature-ancestor (= ?l (:location this))] - [:not [:cold-ancestor (= (:temperature this) (:temperature ?t))]]]]) - -(defn type->keyword - [fact] - (cond - (instance? WindSpeed fact) :windspeed - (instance? Temperature fact) :temperature - (instance? Cold fact) :cold - ;; If we reach the :else case then we are probably calling the user-provided :fact-type-fn - ;; on an internal NegationResult fact which we should not do; see issue 241. - :else (throw (ex-info "A fact that is not a WindSpeed, Temperature, or Cold was provided." - {:fact fact})))) - -(defn keyword->ancestors - [type-key] - (condp = type-key - :windspeed #{:windspeed-ancestor} - :temperature #{:temperature-ancestor} - :cold #{:cold-ancestor} - - (throw (ex-info "A type that is not :windspeed, :temperature, or :cold was provided" - {:type type})))) - -(defsession test-session 'clara.test-complex-negation - :fact-type-fn type->keyword - :ancestors-fn keyword->ancestors) - -(deftest test-complex-negation - (let [different-temps (-> test-session - (insert (->WindSpeed 10 "MCI") - (->Temperature 10 "MCI") - (->Cold 20)) - (fire-rules)) - - same-temps (-> test-session - (insert (->WindSpeed 10 "MCI") - (->Temperature 10 "MCI") - (->Cold 10)) - (fire-rules))] - (is (empty? - (query different-temps negation-inside-negation-query))) - (is (empty? - (query different-temps negation-inside-negation-ancestors-query))) - - (is (= [{:?l "MCI"}] - (query same-temps negation-inside-negation-query) - (query same-temps negation-inside-negation-ancestors-query))))) diff --git a/src/test/clojurescript/clara/test_rules.cljs b/src/test/clojurescript/clara/test_rules.cljs deleted file mode 100644 index aa302263..00000000 --- a/src/test/clojurescript/clara/test_rules.cljs +++ /dev/null @@ -1,240 +0,0 @@ -(ns clara.test-rules - (:require-macros [cljs.test :refer (is deftest run-tests testing)] - [clara.rules.test-rules-data]) - (:require [cljs.test :as t] - [clara.rules.engine :as eng] - [clara.rules.accumulators :as acc] - [clara.rules :refer [insert retract fire-rules query insert!] - :refer-macros [defrule defsession defquery]] - [clara.rules.testfacts :refer [->Temperature Temperature - ->WindSpeed WindSpeed - ->ColdAndWindy ColdAndWindy]])) - -(comment -;; Launch browser repl. - (cemerick.piggieback/cljs-repl :repl-env (cemerick.austin/exec-env)) -) - -(defn- has-fact? [token fact] - (some #{fact} (map first (:matches token)))) - -(def simple-defrule-side-effect (atom nil)) -(def other-defrule-side-effect (atom nil)) - -(defrule test-rule - [Temperature (< temperature 20)] - => - (reset! other-defrule-side-effect ?__token__) - (reset! simple-defrule-side-effect ?__token__)) - -(defquery cold-query - [] - [Temperature (< temperature 20) (== ?t temperature)]) - -;; Accumulator for getting the lowest temperature. -(def lowest-temp (acc/min :temperature)) - -(defquery coldest-query - [] - [?t <- lowest-temp :from [Temperature]]) - -(defrule is-cold-and-windy - "Rule to determine whether it is indeed cold and windy." - - (Temperature (< temperature 20) (== ?t temperature)) - (WindSpeed (> windspeed 30) (== ?w windspeed)) - => - (insert! (->ColdAndWindy ?t ?w))) - -(defrule is-cold-and-windy-map - "A rule which uses a custom type on a map, to determine whether it - is indeed cold and windy" - - [:temp [{degrees :degrees}] (< degrees 20) (== ?t degrees)] - [:wind [{mph :mph}] (> mph 30) (== ?w mph)] - => - (insert! {:type :cold-and-windy - :temp ?t - :wind ?w})) - -(defrule throw-on-bad-temp - "Rule to test exception flow." - [Temperature (> temperature 10000) (= ?t temperature)] - => - (throw (ex-info "Bad temperature!" {:temp ?t}))) - -(defquery find-cold-and-windy - [] - [?fact <- ColdAndWindy]) - -(defquery find-cold-and-windy-map - [] - [?fact <- :cold-and-windy]) - -(defquery wind-without-temperature - [] - [WindSpeed (== ?w windspeed)] - [:not [Temperature]]) - -(defquery wind-with-temperature - [] - [WindSpeed (== ?w windspeed) (== ?loc location)] - [Temperature (== ?t temperature) (== ?loc location)]) - -;; The idea here is that Number will resolve to java.lang.Number in a Clojure environment, -;; so this validates that we correctly handle symbols in a ClojureScript rule that happen -;; to resolve to something in a Clojure environment. Since ClojureScript's compiler -;; is in Clojure failing to handle this correctly can cause us to attempt to embed -;; Java objects in ClojureScript code, which won't work. See issue 300. -(defrecord Number [value]) - -(defquery num-query - [] - [?n <- Number]) - -(defsession my-session 'clara.test-rules) -(defsession my-session-map 'clara.test-rules :fact-type-fn :type) -(defsession my-session-data (clara.rules.test-rules-data/weather-rules)) - -(deftest test-number-query - (is (= (-> my-session - (insert (->Number 5)) - fire-rules - (query num-query)) - [{:?n (->Number 5)}]))) - -(deftest test-simple-defrule - (let [session (insert my-session (->Temperature 10 "MCI"))] - - (fire-rules session) - - (is (has-fact? @simple-defrule-side-effect (->Temperature 10 "MCI"))) - (is (has-fact? @other-defrule-side-effect (->Temperature 10 "MCI"))))) - -(deftest test-simple-query - (let [session (-> my-session - (insert (->Temperature 15 "MCI")) - (insert (->Temperature 10 "MCI")) - (insert (->Temperature 80 "MCI")) - fire-rules)] - - ;; The query should identify all items that wer einserted and matchd the - ;; expected criteria. - (is (= #{{:?t 15} {:?t 10}} - (set (query session cold-query)))))) - -(deftest test-simple-accumulator - (let [session (-> my-session - (insert (->Temperature 15 "MCI")) - (insert (->Temperature 10 "MCI")) - (insert (->Temperature 80 "MCI")) - fire-rules)] - - ;; Accumulator returns the lowest value. - (is (= #{{:?t 10}} - (set (query session coldest-query)))))) - -(deftest test-simple-insert - (let [session (-> my-session - (insert (->Temperature 15 "MCI")) - (insert (->WindSpeed 45 "MCI")) - (fire-rules))] - - (is (= #{{:?fact (->ColdAndWindy 15 45)}} - (set - (query session find-cold-and-windy)))))) - -(deftest test-simple-insert-map - - (let [session (-> my-session-map - (insert {:type :temp :degrees 15}) - (insert {:type :wind :mph 45}) - (fire-rules))] - (is (= #{{:?fact {:type :cold-and-windy :temp 15 :wind 45}}} - (set - (query session find-cold-and-windy-map)))))) - -(deftest test-simple-insert-data - - (let [session (-> my-session-data - (insert (->Temperature 15 "MCI")) - (insert (->WindSpeed 45 "MCI")) - (fire-rules))] - (is (= #{{:?fact (->ColdAndWindy 15 45)}} - (set - (query session "clara.rules.test-rules-data/find-cold-and-windy-data")))))) - -(deftest test-no-temperature - - ;; Test that a temperature cancels the match. - (let [session (-> my-session - (insert (->Temperature 15 "MCI")) - (insert (->WindSpeed 45 "MCI")) - (fire-rules))] - - (is (= #{} - (set - (query session wind-without-temperature))))) - - ;; Now test the no temperature scenario. - (let [session (-> my-session - (insert (->WindSpeed 45 "MCI")) - (fire-rules))] - - (is (= #{{:?w 45}} - (set - (query session wind-without-temperature)))))) - - -(deftest test-simple-join - - (let [session (-> my-session - (insert (->Temperature 15 "MCI")) - (insert (->WindSpeed 45 "MCI")) - (fire-rules))] - - (is (= #{{:?w 45 :?t 15 :?loc "MCI"}} - (set - (query session wind-with-temperature)))))) - -(deftest test-throw-rhs - - (try - (-> my-session - (insert (->Temperature 999999 "MCI")) - (fire-rules)) - (catch :default e - - (is (= {:?t 999999} - (:bindings (ex-data e)))) - (is (= "clara.test-rules/throw-on-bad-temp" - (:name (ex-data e))))))) - -(deftest test-remove-pending-rule-activation - (let [no-activations-session (-> my-session - (insert (->Temperature -10 "ORD") - (->WindSpeed 50 "ORD")) - (retract (->WindSpeed 50 "ORD")) - fire-rules) - - one-activation-session (-> my-session - (insert (->Temperature -10 "ORD") - (->WindSpeed 50 "ORD") - (->WindSpeed 50 "ORD")) - (retract (->WindSpeed 50 "ORD")) - fire-rules)] - - (is (= (query no-activations-session find-cold-and-windy) [])) - (is (= (query one-activation-session find-cold-and-windy) - [{:?fact (->ColdAndWindy -10 50)}])))) - -;;; Basic test of keyword names -(defsession my-session-data-with-keyword-names (clara.rules.test-rules-data/weather-rules-with-keyword-names)) -(deftest test-simple-insert-data-with-keyword-names - - (let [session (-> my-session-data-with-keyword-names - (insert (->Temperature 15 "MCI")) - (insert (->WindSpeed 45 "MCI")) - (fire-rules))] - (is (= [{:?fact (->ColdAndWindy 15 45)}] - (query session :clara.rules.test-rules-data/find-cold-and-windy-data))))) \ No newline at end of file diff --git a/src/test/clojurescript/clara/test_salience.cljs b/src/test/clojurescript/clara/test_salience.cljs deleted file mode 100644 index 96632abe..00000000 --- a/src/test/clojurescript/clara/test_salience.cljs +++ /dev/null @@ -1,115 +0,0 @@ -(ns clara.test-salience - (:require-macros [cljs.test :refer (is deftest run-tests testing)] - [clara.rules.test-rules-data]) - (:require [cljs.test :as t] - [clara.rules.engine :as eng] - [clara.rules.accumulators :as acc] - [clara.rules :refer [insert retract fire-rules query insert!] - :refer-macros [defrule defsession defquery]] - [clara.rules.testfacts :refer [->Temperature Temperature - ->WindSpeed WindSpeed - ->ColdAndWindy ColdAndWindy]])) - -(def salience-rule-output (atom [])) - -(defrule salience-rule1 - {:salience 100} - [Temperature] - => - (swap! salience-rule-output conj 100)) - -(defrule salience-rule2 - {:salience 50} - [Temperature] - => - (swap! salience-rule-output conj 50)) - -(defrule salience-rule3 - {:salience 0} - [Temperature] - => - (swap! salience-rule-output conj 0)) - -(defrule salience-rule4 - {:salience -50} - [Temperature] - => - (swap! salience-rule-output conj -50)) - - -(deftest test-salience - (doseq [[sort-fn - group-fn - expected-order] - - [[:default-sort :default-group :forward-order] - [:default-sort :salience-group :forward-order] - [:default-sort :neg-salience-group :backward-order] - - [:numeric-greatest-sort :default-group :forward-order] - [:numeric-greatest-sort :salience-group :forward-order] - [:numeric-greatest-sort :neg-salience-group :backward-order] - - - [:boolean-greatest-sort :default-group :forward-order] - [:boolean-greatest-sort :salience-group :forward-order] - [:boolean-greatest-sort :neg-salience-group :backward-order] - - - [:numeric-least-sort :default-group :backward-order] - [:numeric-least-sort :salience-group :backward-order] - [:numeric-least-sort :neg-salience-group :forward-order] - - [:boolean-least-sort :default-group :backward-order] - [:boolean-least-sort :salience-group :backward-order] - [:boolean-least-sort :neg-salience-group :forward-order]]] - - (let [numeric-greatest-sort (fn [x y] - (cond - (= x y) 0 - (> x y) -1 - :else 1)) - - numeric-least-sort (fn [x y] - (numeric-greatest-sort y x)) - - salience-group-fn (fn [production] - (or (some-> production :props :salience) - 0)) - - neg-salience-group-fn (fn [p] - (- (salience-group-fn p)))] - - ;; A CLJS macro that behaves like mk-session (creates a session but does not intern a Var) - ;; has been proposed in #292. Internally, this would facilitate session generation for CLJS - ;; tests such as this one, and may be useful if exposed publicly. - - (defsession test-salience-session 'clara.test-salience - :cache false - :activation-group-sort-fn (condp = sort-fn - :default-sort nil - :numeric-greatest-sort numeric-greatest-sort - :numeric-least-sort numeric-least-sort - :boolean-greatest-sort > - :boolean-least-sort <) - :activation-group-fn (condp = group-fn - :default-group nil - :salience-group salience-group-fn - :neg-salience-group neg-salience-group-fn)) - - (reset! salience-rule-output []) - - (-> test-salience-session - (insert (->Temperature 10 "MCI")) - (fire-rules)) - - (let [test-fail-str - (str "Failure with sort-fn: " sort-fn ", group-fn: " group-fn ", and expected order: " expected-order)] - (condp = expected-order - :forward-order - (is (= [100 50 0 -50] @salience-rule-output) - test-fail-str) - - :backward-order - (is (= [-50 0 50 100] @salience-rule-output) - test-fail-str)))))) diff --git a/src/test/common/clara/rule_defs.cljc b/src/test/common/clara/rule_defs.cljc deleted file mode 100644 index 44229983..00000000 --- a/src/test/common/clara/rule_defs.cljc +++ /dev/null @@ -1,39 +0,0 @@ -(ns clara.rule-defs - (:require [clara.rules.accumulators :as acc] - [clara.rules.testfacts :as tf] - [clara.tools.testing-utils :as tu] - #?(:clj [clara.rules :refer [defrule defquery insert!]]) - #?(:cljs [clara.rules :refer-macros [defrule defquery] :refer [insert!]])) - #?(:clj - (:import [clara.rules.testfacts Temperature WindSpeed ColdAndWindy]))) - -;; Rule definitions used for tests in clara.test-rules-require. - -(defrule test-rule - [?t <- #?(:clj Temperature :cljs tf/Temperature) (< temperature 20)] - => - (reset! tu/side-effect-holder ?t)) - -(defquery cold-query - [] - [#?(:clj Temperature :cljs tf/Temperature) (< temperature 20) (== ?t temperature)]) - -;; Accumulator for getting the lowest temperature. -(def lowest-temp (acc/min :temperature)) - -(defquery coldest-query - [] - [?t <- lowest-temp :from [#?(:clj Temperature :cljs tf/Temperature)]]) - -(defrule is-cold-and-windy - "Rule to determine whether it is indeed cold and windy." - - (#?(:clj Temperature :cljs tf/Temperature) (< temperature 20) (== ?t temperature)) - (#?(:clj WindSpeed :cljs tf/WindSpeed) (> windspeed 30) (== ?w windspeed)) - => - (insert! (tf/->ColdAndWindy ?t ?w))) - -(defquery find-cold-and-windy - [] - [?fact <- #?(:clj ColdAndWindy :cljs tf/ColdAndWindy)]) - diff --git a/src/test/common/clara/test_clear_ns_productions.cljc b/src/test/common/clara/test_clear_ns_productions.cljc deleted file mode 100644 index 2a0b52a5..00000000 --- a/src/test/common/clara/test_clear_ns_productions.cljc +++ /dev/null @@ -1,84 +0,0 @@ -;;; Tests that clear-ns-productions! correction clears all vars marked as productions from the namespace. -#?(:clj - (ns clara.test-clear-ns-productions - (:require [clara.tools.testing-utils :as tu] - [clara.rules :refer [fire-rules - insert - insert! - query - defrule - defquery - defsession - clear-ns-productions!]] - [clojure.test :refer [is deftest run-tests testing use-fixtures]])) - :cljs - (ns clara.test-clear-ns-productions - (:require [clara.rules :refer [fire-rules - insert - insert! - query]] - [cljs.test] - [clara.tools.testing-utils :as tu]) - (:require-macros [clara.rules :refer [defrule defquery defsession clear-ns-productions!]] - [cljs.test :refer [is deftest run-tests testing use-fixtures]]))) - -(use-fixtures :each tu/side-effect-holder-fixture) - -(defrule rule-to-be-cleared - [:a] - => - (reset! tu/side-effect-holder :before-clearing) - (insert! :before-clearing)) - -(defquery query-to-be-cleared [] [?f <- :before-clearing]) - -#?(:clj - (def ^:production-seq ns-production-seq-to-be-cleared - [{:doc "Before clearing" - :name "clara.test-clear-ns-productions/production-seq-to-be-cleared" - :lhs '[{:type :a - :constraints []}] - :rhs '(clara.rules/insert! :before-clearing-seq)}])) - -(defsession uncleared-session 'clara.test-clear-ns-productions :fact-type-fn identity) - -(clear-ns-productions!) - -(defrule rule-after-clearing - [:a] - => - (insert! :after-clearing)) - -(defquery query-before-clearing [] [?f <- :before-clearing]) -(defquery query-after-clearing [] [?f <- :after-clearing]) -(defquery query-before-clearing-seq [] [?f <- :before-clearing-seq]) -(defquery query-after-clearing-seq [] [?f <- :after-clearing-seq]) -#?(:clj - (def ^:production-seq production-seq-after-clearing - [{:doc "After clearing" - :name "clara.test-clear-ns-productions/production-seq-after-clearing" - :lhs '[{:type :a - :constraints []}] - :rhs '(clara.rules/insert! :after-clearing-seq)}])) - -(defsession cleared-session 'clara.test-clear-ns-productions :fact-type-fn identity) - -;;; Then tests validating what productions the respective sessions have. -(deftest cleared? - (let [uncleared (-> uncleared-session (insert :a) (fire-rules))] - (is (= :before-clearing @tu/side-effect-holder)) - (reset! tu/side-effect-holder nil)) - (let [cleared (-> cleared-session (insert :a) (fire-rules))] - (testing "cleared-session should not contain any productions before (clear-ns-productions!)" - (is (= nil @tu/side-effect-holder)) - (is (empty? (query cleared query-before-clearing))) - #?(:clj (is (not-empty (query cleared query-after-clearing))))) - (is (empty? (query cleared query-before-clearing-seq))) - #?(:clj (is (not-empty (query cleared query-after-clearing-seq)))))) - -(deftest query-cleared? - (let [uncleared (-> uncleared-session (insert :a) (fire-rules)) - cleared (-> cleared-session (insert :a) (fire-rules))] - (is (not-empty (query uncleared "clara.test-clear-ns-productions/query-to-be-cleared"))) - (is (thrown-with-msg? #?(:clj IllegalArgumentException :cljs js/Error) #"clara.test-clear-ns-productions/query-to-be-cleared" - (query cleared "clara.test-clear-ns-productions/query-to-be-cleared"))))) \ No newline at end of file diff --git a/src/test/common/clara/test_performance_optimizations.cljc b/src/test/common/clara/test_performance_optimizations.cljc deleted file mode 100644 index 0fccfebc..00000000 --- a/src/test/common/clara/test_performance_optimizations.cljc +++ /dev/null @@ -1,62 +0,0 @@ -;; These tests validate that operations that the rules engine should optimize -;; away are in fact optimized away. The target here is not the actual execution time, -;; which will vary per system, but verification that the action operations in question are not performed. -#?(:clj - (ns clara.test-performance-optimizations - (:require [clara.tools.testing-utils :refer [def-rules-test - side-effect-holder] :as tu] - [clara.rules :refer [fire-rules - insert - insert! - query]] - - [clara.rules.testfacts :refer [->Cold ->ColdAndWindy]] - [clojure.test :refer [is deftest run-tests testing use-fixtures]] - [clara.rules.accumulators] - [schema.test :as st]) - (:import [clara.rules.testfacts - Cold - ColdAndWindy])) - - :cljs - (ns clara.test-performance-optimizations - (:require [clara.rules :refer [fire-rules - insert - insert! - query]] - [clara.rules.testfacts :refer [->Cold Cold - ->ColdAndWindy ColdAndWindy]] - [clara.rules.accumulators] - [cljs.test] - [schema.test :as st] - [clara.tools.testing-utils :refer [side-effect-holder] :as tu]) - (:require-macros [clara.tools.testing-utils :refer [def-rules-test]] - [cljs.test :refer [is deftest run-tests testing use-fixtures]]))) - -(use-fixtures :once st/validate-schemas #?(:clj tu/opts-fixture)) -(use-fixtures :each tu/side-effect-holder-fixture) - -#?(:clj - (defmacro true-if-binding-absent - [] - (not (contains? &env '?unused-binding)))) - -;; See issue https://github.com/cerner/clara-rules/issues/383 -;; This validates that we don't create let bindings for binding -;; variables that aren't used. Doing so both imposes runtime costs -;; and increases the size of the generated code that must be evaluated. -(def-rules-test test-unused-rhs-binding-not-bound - - {:rules [cold-windy-rule [[[ColdAndWindy (= ?used-binding temperature) (= ?unused-binding windspeed)]] - (when (true-if-binding-absent) - (insert! (->Cold ?used-binding)))]] - - :queries [cold-query [[] [[Cold (= ?c temperature)]]]] - - :sessions [empty-session [cold-windy-rule cold-query] {}]} - - (is (= [{:?c 0}] - (-> empty-session - (insert (->ColdAndWindy 0 0)) - fire-rules - (query cold-query))))) diff --git a/src/test/common/clara/test_rhs_retract.cljc b/src/test/common/clara/test_rhs_retract.cljc deleted file mode 100644 index 5a6e592e..00000000 --- a/src/test/common/clara/test_rhs_retract.cljc +++ /dev/null @@ -1,62 +0,0 @@ -#?(:clj - (ns clara.test-rhs-retract - (:require [clara.tools.testing-utils :refer [def-rules-test] :as tu] - [clara.rules :refer [fire-rules - insert - insert-all - insert! - retract - query - retract!]] - - [clara.rules.testfacts :refer [->Temperature ->Cold]] - [clojure.test :refer [is deftest run-tests testing use-fixtures]] - [clara.rules.accumulators] - [schema.test :as st]) - (:import [clara.rules.testfacts - Temperature - Cold])) - - :cljs - (ns clara.test-rhs-retract - (:require [clara.rules :refer [fire-rules - insert - insert! - insert-all - retract - query - retract!]] - [clara.rules.testfacts :refer [->Temperature Temperature - ->Cold Cold]] - [clara.rules.accumulators] - [cljs.test] - [schema.test :as st]) - (:require-macros [clara.tools.testing-utils :refer [def-rules-test]] - [cljs.test :refer [is deftest run-tests testing use-fixtures]]))) - -(use-fixtures :once st/validate-schemas #?(:clj tu/opts-fixture)) - -(def-rules-test test-retract! - - {:rules [not-cold-rule [[[Temperature (> temperature 50)]] - (retract! (->Cold 20))]] - - :queries [cold-query [[] - [[Cold (= ?t temperature)]]]] - - :sessions [empty-session [not-cold-rule cold-query] {}]} - - (let [session (-> empty-session - (insert (->Cold 20)) - (fire-rules))] - - ;; The session should contain our initial cold reading. - (is (= #{{:?t 20}} - (set (query session cold-query)))) - - ;; Insert a higher temperature and ensure the cold fact was retracted. - (is (= #{} - (set (query (-> session - (insert (->Temperature 80 "MCI")) - (fire-rules)) - cold-query)))))) diff --git a/src/test/html/advanced.html b/src/test/html/advanced.html deleted file mode 100644 index 5ccb1ba6..00000000 --- a/src/test/html/advanced.html +++ /dev/null @@ -1,5 +0,0 @@ - - - - - diff --git a/src/test/html/simple.html b/src/test/html/simple.html deleted file mode 100644 index fb3cbdcf..00000000 --- a/src/test/html/simple.html +++ /dev/null @@ -1,5 +0,0 @@ - - - - - diff --git a/src/test/js/runner.js b/src/test/js/runner.js deleted file mode 100644 index 0147675b..00000000 --- a/src/test/js/runner.js +++ /dev/null @@ -1,43 +0,0 @@ -var puppeteer = require('puppeteer'); - -if (process.argv.length !== 3) { - console.log('Expected a target URL parameter.'); - process.exit(1); -} - -(async () => { - const browser = await puppeteer.launch({ headless: true }); // Launch headless Chrome - const page = await browser.newPage(); // Create a new page - - // test html file - var url = 'file://' + process.cwd() + '/' + process.argv[2]; - - await page.goto(url); - - page.on('console', async (msg) => { - const msgArgs = msg.args(); - for (let i = 0; i < msgArgs.length; ++i) { - console.log(await msgArgs[i].jsonValue()); - } - }); - - var success = await page.evaluate(() => { - return clara.test.run(); - }) - - await browser.close(); - - return success; -})().then(success => - { - if (success){ - process.exit(0); - } else { - process.exit(1); - } -}) - - - - - diff --git a/tests.edn b/tests.edn new file mode 100644 index 00000000..c1bcc385 --- /dev/null +++ b/tests.edn @@ -0,0 +1,44 @@ +#kaocha/v1 {:capture-output? false + :kaocha/fail-fast? false + :plugins [:kaocha.plugin/profiling + :kaocha.plugin/gc-profiling + :kaocha.plugin/print-invocations + :kaocha.plugin/junit-xml + :kaocha.plugin/cloverage + :kaocha.plugin/hooks + :preloads] + :kaocha.plugin.junit-xml/target-file "target/junit.xml" + :kaocha.plugin.junit-xml/add-location-metadata? true + :cloverage/opts {:ns-exclude-regex [] + :text? false + :lcov? false + :high-watermark 80 + :fail-threshold 0 + :output "target/coverage" + :low-watermark 50 + :src-ns-path ["src/main/clojure" + "src/test/clojure"] + :ns-regex ["clara.coverage-ruleset"] + :summary? true + :coveralls? false + :emma-xml? false + :html? true + :nop? false + :codecov? true} + :kaocha.hooks/pre-report [clara.test-setup/defuse-zero-assertions] + :kaocha.plugin.preloads/ns-names [clara.test-setup] + :tests [{:id :unit + :kaocha/source-paths ["src/main/clojure"] + :kaocha/test-paths ["src/test/clojure"] + :ns-patterns [".*"] + :skip-meta [:generative :coverage]} + {:id :coverage + :kaocha/source-paths ["src/main/clojure"] + :kaocha/test-paths ["src/test/clojure"] + :ns-patterns [".*"] + :focus-meta [:coverage]} + {:id :generative + :kaocha/source-paths ["src/main/clojure"] + :kaocha/test-paths ["src/test/clojure"] + :ns-patterns [".*"] + :focus-meta [:generative]}]} diff --git a/tool/build.clj b/tool/build.clj new file mode 100644 index 00000000..71a8ca3c --- /dev/null +++ b/tool/build.clj @@ -0,0 +1,19 @@ +(ns build + (:require [clojure.tools.build.api :as b])) + +(def basis (b/create-basis {:project "deps.edn"})) + +(defn- compile-java + [sources classes] + (b/javac {:src-dirs sources + :class-dir classes + :basis basis + :javac-opts ["--release" "11"]})) + +(defn compile-main-java + [_] + (compile-java ["src/main/java"] "target/main/classes")) + +(defn compile-test-java + [_] + (compile-java ["src/test/java"] "target/test/classes"))